home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / BITMAP4.ZIP / BITMAP4.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1980-09-12  |  4.0 KB  |  187 lines
  1. Program BitMap4;
  2.  
  3. Uses Dos, Crt;
  4.  
  5. (* By William L. Mabee, CRNA                                        *)
  6. (* Releasd To The Public Domain For Any Use Whatsoever              *)
  7. (* Current Revision 4.1 <*> 10-Sept-1988                            *)
  8. (* Next Revision Planned - Storeage 32 Bits In LongInt              *)
  9. (* Please Excuse Lazy Sceen Handling But This Is A Demo Only.       *)
  10.  
  11. Const
  12.   Header     = 'Test < Bit Mapping Routine >  By : William Mabee';
  13.   MaxBoolean = 32;   (* Number Of Bits To Track.                    *)
  14.   MaxNumber  = 2;    (* This Number Determined By MaxBoolean Div 16 *)
  15.  
  16.  
  17. Type
  18.   BooleanElement = Boolean;
  19.   BooleanArray   = Array[1..MaxBoolean] Of BooleanElement;
  20.   CharSet        = Set Of Char;
  21.  
  22. Const
  23.   YesNo : CharSet = ['Y','N'];
  24.  
  25. Var
  26.   More,Response : Char;
  27.   Ans           : BooleanArray;
  28.   Blank         : String[80];
  29.   Hold          : Array[1..MaxNumber] Of Integer;
  30.   Count,
  31.   I             : Integer;
  32.  
  33. Procedure Beep;
  34. Begin
  35.   Write(^G);
  36. End;
  37.  
  38. Procedure Set_TheBits(Var Flag : Integer; TestArray : BooleanArray; StartNum : Byte);
  39. Var
  40.   Num   : LongInt;
  41.   Count : Integer;
  42. Begin
  43.   Flag := 0; Num := $20480;
  44.   For Count := StartNum To (StartNum + 15) Do
  45.   Begin
  46.     If TestArray[Count] Then Flag := (Flag Or Num);
  47.     Num:= Num Div 2;
  48.   End;
  49. End;
  50.  
  51. Procedure Get_TheBits(Flag : Integer; TestArray : BooleanArray; StartNum : Byte);
  52. Var
  53.   Count : Integer;
  54.   Num   : LongInt;
  55. Begin
  56.   Num := $20480;
  57.   For Count := StartNum To (StartNum + 15) Do
  58.   Begin
  59.     TestArray[Count] := (Flag And Num <> 0);
  60.     Num := Num Div 2;
  61.   End;
  62. End;
  63.  
  64. Procedure InvokeCursor(StartScan,StopScan:integer);
  65. Const
  66.   VideoIO     = $10;
  67.   CursorShape =   1;
  68. Var
  69.   Regs : Registers;
  70. Begin
  71.   With Regs do
  72.   Begin
  73.     Ch := StartScan;
  74.     Cl := StopScan;
  75.     AH := CursorShape;
  76.     Intr(VideoIO,Regs);
  77.   End;
  78. End;
  79.  
  80. Procedure CursorOff;
  81. Begin
  82.   InvokeCursor(32,0);
  83. End;
  84.  
  85. Procedure CursorOn;
  86. Begin
  87.   Case LastMode of
  88.     Font8x8,
  89.     BW40,
  90.     CO40,
  91.     BW80,
  92.     CO80  : InvokeCursor(6,7);
  93.     Mono  : InvokeCursor(12,13);
  94.   End;
  95. End;
  96.  
  97. Procedure Set_Up_Screen;
  98. Begin
  99.   CursorOff;
  100.   Blank := ''; TextColor(Black); TextBackGround(Green);
  101.   ClrScr; WriteLn; WriteLn(Blank:12,Header); WriteLn;
  102. End;
  103.  
  104. Procedure RestoreTheScreen;
  105. Begin
  106.   CursorOff;
  107.   TextColor(LightGray);
  108.   TextBackGround(Black);
  109.   ClrScr;
  110.   CursorOn;
  111. End;
  112.  
  113. Procedure ZeroGlobals;
  114. Begin
  115.   FillChar(Hold,SizeOf(Hold),0);
  116.   FillChar(Ans,SizeOf(Ans),0);
  117. End;
  118.  
  119. Procedure GetTheAnswers;
  120. Begin
  121.   For I := 1 To 32 Do
  122.   Begin
  123.     CursorOff;
  124.     Write(Blank:23,'Question #',I:3,' Answer Y/N : ');
  125.     Repeat
  126.       CursorOn;
  127.       Response := ReadKey;
  128.       Response := UpCase(Response);
  129.       If Response In YesNo Then Else Beep;
  130.     Until Response In YesNo;
  131.     If Response = 'Y' Then Ans[I] := True;
  132.     WriteLn(Response);
  133.     If I Mod 16 = 0 Then Set_Up_Screen;
  134.   End;
  135. End;
  136.  
  137. Procedure DisplayTheBits;
  138. Var
  139.   Col, Row : Byte;
  140.   Message  : String[5];
  141. Begin
  142.   Row := 3; Col := 13; Blank := '';
  143.   For I := 1 To 32 Do
  144.   Begin
  145.     If I Mod 17 = 0 Then
  146.     Begin
  147.       Row := 3; Col := 47;
  148.     End;
  149.     Inc(Row,1);
  150.     GotoXY(Col,Row);
  151.     If Ans[I] = True Then Message := 'True' Else Message := 'False';
  152.     Write('Bit #',I:3,' ',Message);
  153.   End;
  154.   GotoXY(1,20);
  155.   WriteLn;
  156.   WriteLn(Blank:12,'The Integer Hold1 has a value of ',Hold[1]:0,'.');
  157.   WriteLn(Blank:12,'The Integer Hold2 has a value of ',Hold[2]:0,'.');
  158.   WriteLn;
  159. End;
  160.  
  161. Procedure ManipulateTheBits;
  162. Begin
  163.   Set_TheBits(Hold[1],Ans,1);
  164.   Set_TheBits(Hold[2],Ans,17);
  165.   Get_TheBits(Hold[1],Ans,1);
  166.   Get_TheBits(Hold[2],Ans,17);
  167.   CursorOff;
  168. End;
  169.  
  170. Procedure DoItAgain;
  171. Begin
  172.   Write(Blank:12,'Want To Run It Again ? ');
  173.   CursorOn; More := ReadKey; More := Upcase(More);
  174. End;
  175.  
  176. Begin { Main Program BitMap4 }
  177.   Repeat
  178.     ZeroGlobals;
  179.     Set_Up_Screen;
  180.     GetTheAnswers;
  181.     ManipulateTheBits;
  182.     DisplayTheBits;
  183.     DoItAgain;
  184.   Until More <> 'Y';
  185.   RestoreTheScreen;
  186. End.  { Main Program BitMap4 }
  187.