home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB15.ZIP / POLITK.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-07-28  |  13.6 KB  |  337 lines
  1. program politics;
  2. {===================================================================}
  3. {||                                                               ||}
  4. {||   This program demonstrates writing directly to the COLOR     ||}
  5. {||   video memory.  It doesn't work with monochrome -- you ain't ||}
  6. {||   got 16 colors!  It also illustrates the removal of "snow"   ||}
  7. {||   accomplished by waiting for the Horizontal Retrace before   ||}
  8. {||   writing to or reading from the video memory.  It's a bit    ||}
  9. {||   slower, but not nearly as slow as normal BIOS "write".      ||}
  10. {||                                                               ||}
  11. {||        The "game" itself is based on a magazine article I     ||}
  12. {||   once read -- who knows where or when.  It's interesting how ||}
  13. {||   fast "like-minded" people form large blocs and eliminate    ||}
  14. {||   the minorities.  Interesting?  Alarming!                    ||}
  15. {||                                                               ||}
  16. {||        I don't know if POLITICS qualifies as a "cellular      ||}
  17. {||   automata" game or not -- the fact that the changes are      ||}
  18. {||   random may rule it out.  Unlike LIFE, it never truly        ||}
  19. {||   stabilizes, though it always reduces to just a few parties. ||}
  20. {||   (Since a "lost" party never returns, the trend is clearly   ||}
  21. {||   toward simplification)                                      ||}
  22. {||                                                               ||}
  23. {||                       ENJOY IT!                               ||}
  24. {||                                                               ||}
  25. {||         --- Neil J. Rubenking --                              ||}
  26. {||                                                               ||}
  27. {||     Technical Assistance : Julius Marx                        ||}
  28. {===================================================================}
  29. {||   SUGGESTIONS FOR  "TWEAKERS"                                 ||}
  30. {||                                                               ||}
  31. {||       If the 25x50 "resolution" isn't fine enough for you,    ||}
  32. {||   you might try filling the screen with character 223, the    ||}
  33. {||   "top half box".  Then you manipulate the foreground and     ||}
  34. {||   background colors separately -- the foreground color will   ||}
  35. {||   appear in the top half, and the background in the bottom.   ||}
  36. {||   Of course, you only get 8 colors, as you can't have a       ||}
  37. {||   "bright" background (can you?).  The effect will be that    ||}
  38. {||   of a 50x50 grid of smaller boxes.                           ||}
  39. {||                                                               ||}
  40. {||        Monochrome users might try characters 219, 178, 177,   ||}
  41. {||   and 176.  These four in HighVideo and LowVideo, plus the    ||}
  42. {||   black blank, would give you 9 "parties".                    ||}
  43. {||                                                               ||}
  44. {===================================================================}
  45.  
  46.  
  47. type
  48.   string30 = string[30];
  49.   screen   = array[1..25] of array[1..80] of integer;
  50.   ScrPt    = ^screen;
  51.   regpack  = record ax,bx,cx,dx,bp,si,di,ds,es,flags: integer; end;
  52. const
  53.   pt  : byte = 178;  { I like the "quilted" effect these characters give. }
  54.   pt1 : byte = 178;  { For a different display, comment out these values  }
  55.   pt2 : byte = 178;  { and un-comment the next few lines                  }
  56. (*
  57.   pt  : byte = 5;    { Character 5 is the "spade", but it looks kind      }
  58.   pt1 : byte = 17;   { of like a person.  Characters 17 and 16 together   }
  59.   pt2 : byte = 16;   { form a diamond shape two characters wide           }
  60. *)
  61. var
  62.   ScreenSeg                  : integer;
  63.   Freedonia                  : screen;
  64.   regs                       : regpack;
  65.   display                    : scrPt;
  66.   vidMode, numCols, row, col : byte;
  67.   CheatVar, VidOffset        : integer ;
  68.  
  69.  
  70. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  71. procedure Cursor(mode : char);
  72. {PURPOSE: Turn cursor on and off -- mode 'Y' is ON, 'N' is off.
  73.           Color cursor has 7 scan lines, numbered 0 to 6, from the
  74.           top.  Normal cursor is lines 6 & 7.  Monochrome is 0 to 13,
  75.           with normal begin 12 & 13.  According to Tech Ref, "setting
  76.           bits 5 or 6 will cause erratic blinking or no cursor at all",
  77.           and that's just what we do for NO cursor (48 = 110000b)
  78. }
  79. begin
  80.   with regs do
  81.     begin
  82.       AX := 1 shl 8;
  83.       case mode of
  84.         'Y': if seg(display^) = $B000 then
  85.                  CX := (12 shl 8) + 13
  86.              else
  87.                  CX := (5 shl 8) + 6;
  88.         'N': CX := 48 shl 8;
  89.       end;
  90.       Intr($10,regs);
  91.     end;
  92. end;
  93. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  94. procedure CheckColor;
  95. {PURPOSE: Sets the pointer "display" to point at the current video memory.
  96.           "VidMode" contains a number from 0 to 7 -- 7 is MONOchrome adapter
  97.           card, the others are color:
  98.                  0 40x25    BW    \
  99.                  1 40x25    color  \
  100.                  2 80x25    BW      \
  101.                  3 80x25    color    > all color/graphics modes
  102.                  4 320x200  color   /
  103.                  5 320x200  BW     /
  104.                  6 640x200  BW    /
  105.           "NumCols" is set to the number of text columns on the screen
  106. }
  107. begin
  108.   with regs do
  109.     begin
  110.       AX := 15 shl 8;
  111.       intr($10,regs);
  112.       vidmode := AX and $00FF;
  113.       NumCols := AX shr 8;
  114.     end;
  115.   if vidmode = 7 then ScreenSeg := $B000 else ScreenSeg := $B800;
  116.   Display := Ptr(ScreenSeg,$0000)
  117. end;
  118. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  119. procedure Hail_Freedonia;
  120. begin
  121.   window(53,1,80,14);
  122.   textColor(LightRed); TextBackground(blue);
  123.   CLrScr;
  124.   write(#4#4#4#4#4#4,' HAIL FREEDONIA ',#4#4#4#4#4#4);
  125.   TextColor(Lightgreen);
  126.   writeLn;
  127.   writeLn('   Freedonia''s   citizens');
  128.   writeLn(' belong to  14  different');    { NOTE:  I know there are 16 }
  129.   writeLn(' political parties,  here');    { colors, not 14, but BLACK  }
  130.   writeLn(' symbolized by 14 colors.');    { and DARKGRAY aren't very   }
  131.   writeLn(' They are  distributed at');    { visible against a black    }
  132.   writeLn(' random to start,  but at');    { background!                }
  133.   writeLn(' each moment,  a randomly');
  134.   writeLn(' chosen citizen  converts');
  135.   writeLn(' to the  party  of one of');
  136.   writeLn(' his/her neighbors.      ');
  137. end;
  138. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  139. procedure message(L1,L2,L3,L4 : string30);
  140. begin
  141.   window(53,16,80,22);
  142.   TextColor(yellow); TextBackground(green);
  143.   ClrScr;
  144.   writeLn('    NEXT EVENT');
  145.   writeLn;
  146.   writeLN(L1);
  147.   writeLn(L2);
  148.   writeLn(L3);
  149.   writeLn(L4);
  150. end;
  151. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  152. procedure WaitAndPut(R,C:byte; XX : integer);
  153. {PURPOSE: Wait for retrace,  poke in a character}
  154. begin
  155.   VidOffset := (r-1)*160 + (c-1)*2;
  156.   CheatVar := XX;
  157.   { ^ }
  158.   { | }
  159.   { | }
  160.   {---------------------------------------------}
  161.   {  NOTE:  As I'm not very fluent in INLINE,   }
  162.   {    I've defined two GLOBAL variables to     }
  163.   {    handle some of the value-passing.  It    }
  164.   {    ain't elegant, but it does the job.      }
  165.   {---------------------------------------------}
  166.  
  167.   INLINE(
  168.     $A1/CheatVar/       { MOV AX,CheatVar          }
  169.     $8B/$1E/VidOffset/   { MOV BX,VidOffset          }
  170.     $1E/                 {PUSH DS                    }
  171.     $50/                 {PUSH AX                    }
  172.     $B8/$B800/           { MOV AX,0B800h             }
  173.     $8E/$D8/             { MOV DS,AX                 }
  174.     $BA/$DA/$03/         { MOV DX,03DA               }
  175.     $EC/                 {IN      AL,DX              }
  176.     $A8/$01/             {TEST    AL,01              }
  177.     $75/$FB/             {Jnz     (back to IN AL,DX) }
  178.     $FA/                 {CLI                        }
  179.     $EC/                 {IN      AL,DX              }
  180.     $A8/$01/             {TEST    AL,01              }
  181.     $74/$FB/             {Jz    (back to IN AL,DX)   }
  182.     $58/                 {POP AX                     }
  183.     $89/$07/             { MOV [BX], AX              }
  184.     $1F/                 {POP DS                     }
  185.     $FB);                { STI                       }
  186. end; { procedure WaitAndPUT2(R,C:byte; XX : integer) }
  187. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  188. procedure WaitAndGet(R,C:byte; VAR XX : integer);
  189. {PURPOSE: Wait for retrace,  read a character}
  190. begin
  191.   VidOffset := (r-1)*160 + (c-1)*2;
  192.   INLINE(
  193.     $A1/CheatVar/       { MOV AX,CheatVar          }
  194.     $8B/$1E/VidOffset/   { MOV BX,VidOffset          }
  195.     $1E/                 {PUSH DS                    }
  196.     $B8/$B800/           { MOV AX,0B800h             }
  197.     $8E/$D8/             { MOV DS,AX                 }
  198.     $BA/$DA/$03/         { MOV DX,03DA               }
  199.     $EC/                 {IN      AL,DX              }
  200.     $A8/$01/             {TEST    AL,01              }
  201.     $75/$FB/             {Jnz     (back to IN AL,DX) }
  202.     $FA/                 {CLI                        }
  203.     $EC/                 {IN      AL,DX              }
  204.     $A8/$01/             {TEST    AL,01              }
  205.     $74/$FB/             {Jz    (back to IN AL,DX)   }
  206.     $8B/$07/             { MOV AX, [BX]              }
  207.     $1F/                 {POP DS                     }
  208.     $A3/CheatVar/        { MOV CheatVar,AX           }
  209.     $FB);                { STI                       }
  210.   XX := CheatVar;
  211. end; { procedure WaitAndGet(R,C:byte; VAR XX : integer) }
  212. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  213. procedure initialize(size:byte);
  214. { PURPOSE: initialize the country of Freedonia with citizens of 14 parties.
  215.            If "size" is 1, Freedonia consists of 25 rows of 50 single-
  216.            character citizens, using character determined by the constant
  217.            "PT".  If size is 2, there are 25x25 citizens, made of the
  218.            characters PT1 and PT2.}
  219. var
  220.   OneSpot : integer;
  221.   {=================================================================}
  222.   function RandomColor:byte;
  223.   var temp : byte;
  224.   begin
  225.     temp := random(15)+1;
  226.     if temp = 8 then temp := randomColor;
  227.     randomColor := temp;
  228.   end;
  229.   {=================================================================}
  230. begin
  231.   FillChar(Freedonia,SizeOf(FreeDonia),0);
  232.   if size = 1 then
  233.     for row := 1 to 25 do
  234.       for col := 1 to 50 do
  235.         Freedonia[row][col] := pt or (randomColor shl 8)
  236.   else
  237.     for row := 1 to 25 do
  238.       for col := 1 to 25 do
  239.         begin
  240.           OneSpot :=  (randomColor shl 8);
  241.           Freedonia[row][col*2-1] := OneSpot or pt1;
  242.           Freedonia[row][col*2] := OneSpot or pt2;
  243.         end;
  244.   display^ := Freedonia;
  245.   Hail_Freedonia;
  246. end;
  247. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  248. procedure ChangeOfHeart(size:byte; wait : boolean);
  249. {PURPOSE: select a "citizen" at random.  Select a direction at random.
  250.           Convert the neighbor in the chosen direction to the same party
  251.           as the chosen citizen.  If "wait" is true, demonstrate wait
  252.           for Horizontal Retrace -- otherwise, just whomp the new
  253.           character to the screen.}
  254.  
  255. var
  256.   dir, changeTo : byte;
  257.   DH : integer;
  258. begin
  259.   row := random(25) + 1 ;
  260.   col := random(25 * (3-size)) + 1;
  261.   dir := random(8) +  1;
  262.   if wait then
  263.     WaitAndGet(row,col*size,DH)
  264.   else
  265.     DH  := display^[row][col*size];
  266.   case dir of
  267.     1..3: if row > 1 then row := row - 1 else row := 25;
  268.     6..8: if row < 25 then row := row + 1 else row := 1;
  269.   end;
  270.   case dir of
  271.     1,4,6: if col > 1 then col := col - 1 else col := (25*(3-size));
  272.     3,5,8: if col < (25 * (3-size)) then col := col + 1 else col := 1;
  273.   end;
  274.   if size = 1 then
  275.     if wait then WaitAndPut(row,col,DH)
  276.       else display^[row][col] := DH
  277.   else
  278.     begin
  279.       if wait then
  280.         begin
  281.           WaitAndPut(row,2*col-1,(DH and $FF00) or pt1);
  282.           WaitAndPut(row,2*col,(DH and $FF00) or pt2);
  283.         end
  284.       else
  285.         begin
  286.           display^[row][2*col-1] := (DH and $FF00) or pt1;
  287.           display^[row][2*col] := (DH and $FF00) or pt2;
  288.         end;
  289.     end;
  290. end;
  291. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  292. begin
  293.   ClrScr;
  294.   CHeckColor;
  295.   if VidMode = 7 then
  296.     begin
  297.       writeLn('Sorry, friend.  This program only works with COLOR SCREENS.');
  298.     end
  299.   else
  300.     begin
  301.       randomize;
  302.       cursor('N');
  303.       initialize(1);
  304.       message(' Press <return> to start',' conversions.  Writing to',
  305.               ' screen memory directly.','');
  306.       read;
  307.       message(' Press <return> to write',' to screen with Horizon-',
  308.               ' tal Retrace check.  Its',' slower, but no snow.');
  309.       repeat
  310.         ChangeOfHeart(1,false);
  311.       until keypressed;
  312.       read;
  313.       message(' Press <return> to start',' again with "people" of',
  314.               ' larger size','');
  315.       repeat
  316.         ChangeOfHeart(1,true);
  317.      until keypressed;
  318.      read(Kbd);
  319.       read;
  320.       initialize(2);
  321.       message(' Press <return> to start',' conversions.  Writing to',
  322.               ' screen memory directly.','');
  323.       read;
  324.       message(' Press <return> to write',' to screen with Horizon-',
  325.               ' tal Retrace check.  Its',' slower, but no snow.');
  326.       repeat
  327.         ChangeOfHeart(2,false);
  328.       until keypressed;  read(Kbd);
  329.       read;
  330.       message(' Press <return> to end','','','');
  331.       repeat
  332.         ChangeOfHeart(2,true);
  333.       until keypressed;  read(Kbd);
  334.       cursor('Y');
  335.     end;
  336. end.
  337.