-- F392C00.A -- -- Grant of Unlimited Rights -- -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained -- unlimited rights in the software and documentation contained herein. -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making -- this public release, the Government intends to confer upon all -- recipients unlimited rights equal to those held by the Government. -- These rights include rights to use, duplicate, release or disclose the -- released technical data and computer software in whole or in part, in -- any manner and for any purpose whatsoever, and to have or permit others -- to do so. -- -- DISCLAIMER -- -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A -- PARTICULAR PURPOSE OF SAID MATERIAL. --* -- -- FOUNDATION DESCRIPTION: -- This foundation provides a basis for tagged type and dispatching -- tests. Each test describes the utilizations. -- -- CHANGE HISTORY: -- 06 Dec 94 SAIC ACVC 2.0 -- 24 OCT 95 SAIC Updated for ACVC 2.0.1 -- --! package F392C00_1 is -- Switches type Toggle is tagged private; ---------------------------------- Toggle function Create return Toggle; procedure Flip ( It : in out Toggle ); function On ( It : Toggle'Class ) return Boolean; function Off ( It : Toggle'Class ) return Boolean; type Dimmer is new Toggle with private; ------------------------- Dimmer type Luminance is range 0..100; function Create return Dimmer; procedure Flip ( It : in out Dimmer ); procedure Brighten( It : in out Dimmer; By : in Luminance := 10 ); procedure Dim ( It : in out Dimmer; By : in Luminance := 10 ); function Intensity( It : Dimmer ) return Luminance; type Auto_Dimmer is new Dimmer with private; --------------- Auto_Dimmer function Create return Auto_Dimmer; procedure Flip ( It: in out Auto_Dimmer ); procedure Set_Auto ( It: in out Auto_Dimmer ); procedure Clear_Auto( It: in out Auto_Dimmer ); -- procedure Set_Manual( It: in out Auto_Dimmer ) renames Clear_Auto; procedure Set_Cutin ( It: in out Auto_Dimmer; Lumens: in Luminance ); procedure Set_Cutout( It: in out Auto_Dimmer; Lumens: in Luminance ); function Auto ( It: Auto_Dimmer ) return Boolean; function Cutout_Threshold( It: Auto_Dimmer ) return Luminance; function Cutin_Threshold ( It: Auto_Dimmer ) return Luminance; function TC_CW_TI( Key : Character ) return Toggle'Class; function TC_Non_Disp( It: Toggle ) return Boolean; function TC_Non_Disp( It: Dimmer ) return Boolean; function TC_Non_Disp( It: Auto_Dimmer ) return Boolean; private type Toggle is tagged record On : Boolean := False; end record; type Dimmer is new Toggle with record Intensity : Luminance := 100; end record; type Auto_Dimmer is new Dimmer with record Cutout_Threshold : Luminance := 60; Cutin_Threshold : Luminance := 40; Auto_Engaged : Boolean := False; end record; end F392C00_1; with TCTouch; package body F392C00_1 is function Create return Toggle is begin TCTouch.Touch( '1' ); ------------------------------------------------ 1 return Toggle'( On => True ); end Create; function Create return Dimmer is begin TCTouch.Touch( '2' ); ------------------------------------------------ 2 return Dimmer'( On => True, Intensity => 75 ); end Create; function Create return Auto_Dimmer is begin TCTouch.Touch( '3' ); ------------------------------------------------ 3 return Auto_Dimmer'( On => True, Intensity => 25, Cutout_Threshold | Cutin_Threshold => 50, Auto_Engaged => True ); end Create; procedure Flip ( It : in out Toggle ) is begin TCTouch.Touch( 'A' ); ------------------------------------------------ A It.On := not It.On; end Flip; function On( It : Toggle'Class ) return Boolean is begin TCTouch.Touch( 'B' ); ------------------------------------------------ B return It.On; end On; function Off( It : Toggle'Class ) return Boolean is begin TCTouch.Touch( 'C' ); ------------------------------------------------ C return not It.On; end Off; procedure Brighten( It : in out Dimmer; By : in Luminance := 10 ) is begin TCTouch.Touch( 'D' ); ------------------------------------------------ D if (It.Intensity+By) <= Luminance'Last then It.Intensity := It.Intensity+By; else It.Intensity := Luminance'Last; end if; end Brighten; procedure Dim ( It : in out Dimmer; By : in Luminance := 10 ) is begin TCTouch.Touch( 'E' ); ------------------------------------------------ E if (It.Intensity-By) >= Luminance'First then It.Intensity := It.Intensity-By; else It.Intensity := Luminance'First; end if; end Dim; function Intensity( It : Dimmer ) return Luminance is begin TCTouch.Touch( 'F' ); ------------------------------------------------ F if On(It) then return It.Intensity; else return Luminance'First; end if; end Intensity; procedure Flip ( It : in out Dimmer ) is begin TCTouch.Touch( 'G' ); ------------------------------------------------ G if On( It ) and (It.Intensity < 50) then It.Intensity := Luminance'Last - It.Intensity; else Flip( Toggle( It ) ); end if; end Flip; procedure Set_Auto ( It: in out Auto_Dimmer ) is begin TCTouch.Touch( 'H' ); ------------------------------------------------ H It.Auto_Engaged := True; end Set_Auto; procedure Clear_Auto( It: in out Auto_Dimmer ) is begin TCTouch.Touch( 'I' ); ------------------------------------------------ I It.Auto_Engaged := False; end Clear_Auto; function Auto ( It: Auto_Dimmer ) return Boolean is begin TCTouch.Touch( 'J' ); ------------------------------------------------ J return It.Auto_Engaged; end Auto; procedure Flip ( It: in out Auto_Dimmer ) is begin TCTouch.Touch( 'K' ); ------------------------------------------------ K if It.Auto_Engaged then if Off(It) then Flip( Dimmer( It ) ); else It.Auto_Engaged := False; end if; else Flip( Dimmer( It ) ); end if; end Flip; procedure Set_Cutin ( It : in out Auto_Dimmer; Lumens : in Luminance) is begin TCTouch.Touch( 'L' ); ------------------------------------------------ L It.Cutin_Threshold := Lumens; end Set_Cutin; procedure Set_Cutout( It : in out Auto_Dimmer; Lumens : in Luminance) is begin TCTouch.Touch( 'M' ); ------------------------------------------------ M It.Cutout_Threshold := Lumens; end Set_Cutout; function Cutout_Threshold( It : Auto_Dimmer ) return Luminance is begin TCTouch.Touch( 'N' ); ------------------------------------------------ N return It.Cutout_Threshold; end Cutout_Threshold; function Cutin_Threshold ( It : Auto_Dimmer ) return Luminance is begin TCTouch.Touch( 'O' ); ------------------------------------------------ O return It.Cutin_Threshold; end Cutin_Threshold; function TC_CW_TI( Key : Character ) return Toggle'Class is begin TCTouch.Touch( 'W' ); ------------------------------------------------ W case Key is when 'T' | 't' => return Toggle'( On => True ); when 'D' | 'd' => return Dimmer'( On => True, Intensity => 75 ); when 'A' | 'a' => return Auto_Dimmer'( On => True, Intensity => 25, Cutout_Threshold | Cutin_Threshold => 50, Auto_Engaged => True ); when others => null; end case; end TC_CW_TI; function TC_Non_Disp( It: Toggle ) return Boolean is begin TCTouch.Touch( 'X' ); ------------------------------------------------ X return It.On; end TC_Non_Disp; function TC_Non_Disp( It: Dimmer ) return Boolean is begin TCTouch.Touch( 'Y' ); ------------------------------------------------ Y return It.On; end TC_Non_Disp; function TC_Non_Disp( It: Auto_Dimmer ) return Boolean is begin TCTouch.Touch( 'Z' ); ------------------------------------------------ Z return It.On; end TC_Non_Disp; end F392C00_1;