home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / turbopas / tp / utl2 / utl2.lbr / BITMAP2.PZS / BITMAP2.PAS
Pascal/Delphi Source File  |  1987-04-26  |  2KB  |  76 lines
  1. PROGRAM bit_map2;
  2.  
  3. (*
  4.  
  5. Original work by Steve Fox
  6.  
  7. Bit_Map2 modifications by W. Mabee, CRNA and H. Kaemerrer.
  8.  
  9. Demonstrates compression of 8 boolean variables into a single
  10. byte. Anyone know if you can accomplish the same thing with
  11. shl or shr.
  12.  
  13. *)
  14.  
  15. CONST
  16.   header = 'Test < Bit Mapping Routine >';
  17.  
  18. VAR
  19.   more,response : CHAR;
  20.   ans           : ARRAY[1..8] OF BOOLEAN;
  21.   hold          : BYTE;
  22.   i             : INTEGER;
  23.  
  24. PROCEDURE set_bits(VAR flag : BYTE; a,b,c,d,e,f,g,h : BOOLEAN);
  25. BEGIN
  26.   flag := 0;
  27.   IF a THEN flag := flag OR $80;
  28.   IF b THEN flag := flag OR $40;
  29.   IF c THEN flag := flag OR $20;
  30.   IF d THEN flag := flag OR $10;
  31.   IF e THEN flag := flag OR $08;
  32.   IF f THEN flag := flag OR $04;
  33.   IF g THEN flag := flag OR $02;
  34.   IF h THEN flag := flag OR $01
  35. END;
  36.  
  37. PROCEDURE get_bits(flag : BYTE; VAR a,b,c,d,e,f,g,h : BOOLEAN);
  38. BEGIN
  39.   a := (flag AND $80 <> 0);
  40.   b := (flag AND $40 <> 0);
  41.   c := (flag AND $20 <> 0);
  42.   d := (flag AND $10 <> 0);
  43.   e := (flag AND $08 <> 0);
  44.   f := (flag AND $04 <> 0);
  45.   g := (flag AND $02 <> 0);
  46.   h := (flag AND $01 <> 0)
  47. END;
  48.  
  49. PROCEDURE set_up_screen;
  50. BEGIN
  51.   CLRSCR; WRITELN; WRITELN(header); WRITELN;
  52. END;
  53.  
  54. BEGIN
  55.   REPEAT
  56.     set_up_screen;
  57.     FOR i := 1 TO 8 DO
  58.     BEGIN
  59.       WRITE('Question # ',i,' Answer Y/N : ');
  60.       READ(KBD,response); WRITELN(UPCASE(response));
  61.       ans[i] := (response IN ['Y','y'])
  62.     END;
  63.     set_bits(hold,ans[1],ans[2],ans[3],ans[4],ans[5],ans[6],ans[7],ans[8]);
  64.     get_bits(hold,ans[1],ans[2],ans[3],ans[4],ans[5],ans[6],ans[7],ans[8]);
  65.     WRITELN;
  66.     FOR i := 1 TO 8 DO
  67.     BEGIN
  68.       WRITE('Bit # ',i);
  69.       IF ans[i] = TRUE THEN WRITELN(' is true.') ELSE WRITELN(' is false.');
  70.     END;
  71.     WRITELN;
  72.     WRITE('The byte has a value of ',hold,'. Want to run it again ? ');
  73.     READ(KBD,more); more := UPCASE(more);
  74.   UNTIL more <> 'Y';
  75. END.
  76.