home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG153.ARC / LS.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  14KB  |  489 lines
  1. program LetterShift;
  2. { programmed by:   Konstantin Articus
  3.                    Gross strasse 21
  4.                    2250 Husum
  5.                    West Germany
  6.  
  7.   This game is Public Domain.
  8.   You may change it for your own purpose.
  9.  
  10.   last changes: 23.6.1989
  11.  
  12.   Converted from DOS to Microbee CP/M
  13.   by A J Laughton on 14th October '90 }
  14.  
  15. var
  16. again,i,index,indicator,shuffl,OldDir,empty : integer;
  17. finished : boolean;
  18. place  : array[1..16] of string[1];
  19. result : array[1..4] of integer;
  20. moves,
  21. number : real;
  22.  
  23. const
  24.    TL  = #128;  { Top Left     Border characters }
  25.    TR  = #129;  { Top Right       }
  26.    BL  = #130;  { Bottom Left     }
  27.    BR  = #131;  { Bottom Right    }
  28.    TM  = #132;  { Top Middle      }
  29.    BM  = #133;  { Bottom Middle   }
  30.    HL  = #134;  { Horizontal Line }
  31.    VL  = #135;  { Vertical Line   }
  32.    LM  = #136;  { Left Middle     }
  33.    RM  = #137;  { Right Middle    }
  34.    Cr  = #138;  { Center Cross    }
  35.  
  36. Procedure BorderPCGs;
  37. Var
  38.    X : integer;
  39.    J : byte;
  40. Begin
  41.      For x:=$F800 to $F80B do   {TLeft}
  42.        Begin
  43.          Case x of
  44.               $F800..$F803 : J:=$00;
  45.               $F804        : J:=$0F;
  46.               $F805,$F806  : J:=$1F;
  47.               $F807        : J:=$1C;
  48.               $F808..$F80A : J:=$18;
  49.           end;
  50.           Mem[x]:=j;
  51.        End;
  52.      For x:=$F810 to $F81B do   {TRight}
  53.        Begin
  54.          Case x of
  55.               $F810..$F813 : J:=$00;
  56.               $F814        : J:=$F0;
  57.               $F815,$F816  : J:=$F8;
  58.               $F817        : J:=$38;
  59.               $F818..$F81A : J:=$18;
  60.           end;
  61.           Mem[x]:=j;
  62.        End;
  63.      For x:=$f820 to $F82B do   {BLeft}
  64.        Begin
  65.          Case x of
  66.               $F820..$F822 : J:=$18;
  67.               $F823        : J:=$1C;
  68.               $F824,$F825  : J:=$1F;
  69.               $F826        : J:=$0F;
  70.               $F827..$F82A : J:=$00;
  71.           end;
  72.           Mem[x]:=j;
  73.        End;
  74.      For x:=$F830 to $F83B do   {BRight}
  75.        Begin
  76.          Case x of
  77.               $F830..$F832 : J:=$18;
  78.               $F833        : J:=$38;
  79.               $F834,$F835  : J:=$F8;
  80.               $F836        : J:=$F0;
  81.               $F837..$F83A : J:=$00;
  82.           end;
  83.           Mem[x]:=j;
  84.        End;
  85.      For x:=$F840 to $F84B do   {TMid}
  86.        Begin
  87.          Case x of
  88.               $F840..$F843 : J:=$00;
  89.               $F844        : J:=$81;
  90.               $F845        : J:=$E7;
  91.               $F846        : J:=$FF;
  92.               $F847        : J:=$3C;
  93.               $F848..$F84A : J:=$18;
  94.           end;
  95.           Mem[x]:=j;
  96.        End;
  97.     For x:=$F850 to $F85B do   {BMid}
  98.        Begin
  99.          Case x of
  100.               $F850..$F852 : J:=$18;
  101.               $F853        : J:=$3C;
  102.               $F854        : J:=$FF;
  103.               $F855        : J:=$E7;
  104.               $F856        : J:=$81;
  105.               $F857..$F85A : J:=$00;
  106.           end;
  107.           Mem[x]:=j;
  108.        End;
  109.     For x:=$F860 to $F86B do {HLin}
  110.         Begin
  111.           Case x of
  112.                $F860..$F863 : J:=$00;
  113.                $F864..$F866 : J:=$FF;
  114.                $F867..$F86B : J:=$00;
  115.           end;
  116.           Mem[x]:=j;
  117.         End;
  118.     For x:=$F880 to $F88B do  {LMid}
  119.         Begin
  120.           Case x of
  121.                $F880..$F882,$F888..$F88A : J:=$18;
  122.                $F883,$F887               : J:=$1C;
  123.                $F884,$F886               : J:=$0F;
  124.                $F885                     : J:=$07;
  125.           End;
  126.           Mem[x]:=j;
  127.         End;
  128.     For x:=$F890 to $F89B do  {RMid}
  129.         Begin
  130.           Case x of
  131.                $F890..$F892,$F898..$F89A : J:=$18;
  132.                $F893,$F897               : J:=$38;
  133.                $F894,$F896               : J:=$F0;
  134.                $F895                     : J:=$E0;
  135.           end;
  136.           Mem[x]:=j;
  137.         End;
  138.     For x:=$F870 to $F87B do  {VLin}
  139.         Mem[x]:=$18;
  140.     For x:=$F8A0 to $F8AB do   {Cross}
  141.         Begin
  142.           Case x of
  143.                $F8A0..$F8A2,$F8A8..$F8AA : J:=$18;
  144.                $F8A3,$F8A7               : J:=$3C;
  145.                $F8A4..$F8A6              : J:=$FF;
  146.           End;
  147.           Mem[x]:=j;
  148.         End;
  149. End;
  150.  
  151. procedure bold;
  152.   begin                   { SCNTOP  EQU     0F000H }
  153.                           { PCGRAM  EQU     0F800H }
  154.                           { ROMPORT EQU     0BH    }
  155.     inline(
  156.        $3E/$01/           {BOLD:    LD      A,1         }
  157.        $D3/$0B/           {         OUT     (ROMPORT),A }
  158.        $21/$F000/         {         LD      HL,SCNTOP   }
  159.        $11/$F800/         {         LD      DE,PCGRAM   }
  160.        $7E/               {BOLD_1:  LD      A,(HL)      }
  161.        $07/               {         RLCA                }
  162.        $B6/               {         OR      (HL)        }
  163.        $12/               {         LD      (DE),A      }
  164.        $23/               {         INC     HL          }
  165.        $13/               {         INC     DE          }
  166.        $CB/$5C/           {         BIT     3,H         }
  167.        $28/$F6/           {         JR      Z,BOLD_1    }
  168.        $AF/               {         XOR     A           }
  169.        $D3/$0B )          {         OUT     (ROMPORT),A }
  170.   end;
  171.  
  172. procedure Inverse;
  173.   begin                   { SCNTOP      EQU      0F000H  }
  174.                           { PCGRAM      EQU      0F800H  }
  175.                           { ROMPORT     EQU      0BH     }
  176.                           { INVERSE:                     }
  177. inline($3E/ $01/          {          LD      A,1         }
  178.        $D3/ $0B/          {          OUT     (ROMPORT),A }
  179.        $21/ $F000/        {          LD      HL,SCNTOP   }
  180.        $11/ $F800/        {          LD      DE,PCGRAM   }
  181.        $7E/               { INV_1:   LD      A,(HL)      }
  182.        $2F/               {          CPL                 }
  183.        $12/               {          LD      (DE),A      }
  184.        $23/               {          INC     HL          }
  185.        $13/               {          INC     DE          }
  186.        $CB/ $5C/          {          BIT     3,H         }
  187.        $28/ $F7/          {          JR      Z,INV_1     }
  188.        $AF/               {          XOR     A           }
  189.        $D3/ $0B );        {          OUT     (ROMPORT),A }
  190. end;
  191.  
  192. procedure RestoreAll;
  193.   begin
  194.     port[$1c] := $80;       {Restore PCG Ram to normal inverse chr's}
  195.     inverse;
  196.   end;
  197.  
  198. procedure DeleteLine(x,y:integer);
  199. begin
  200.   gotoxy(x,y);
  201.   for i := 1 to (78-x) do
  202.     write(' ');
  203. end;
  204.  
  205. procedure Border;
  206. var
  207.   x,j : integer;
  208.   begin
  209.     clrscr;
  210.     gotoxy(1,1);
  211.     write(TL);
  212.     for i := 1 to 78 do
  213.       write(HL);
  214.     write(TR,VL);
  215.     for i := 0 to 20 do
  216.       begin
  217.         gotoxy(80,2+i);
  218.         write(VL,VL);
  219.       end;
  220.     write(#8,BL);
  221.     for i := 1 to 78 do
  222.       write(HL);
  223.     write(BR);
  224.     gotoxy(1,1);
  225.   end;
  226.  
  227. procedure ScreenSetUp;
  228. var line,
  229.     plus : integer;
  230.   begin
  231.     gotoxy(19,23);
  232.     write(' No. of moves: ',moves:3:0,' ');
  233.     gotoxy(32,3);
  234.     Lowvideo;
  235.       writeln('L E T T E R   S H I F T');
  236.     Normvideo;
  237.     gotoxy(20,5);
  238.     writeln(TL,HL,HL,HL,TM,HL,HL,HL,TM,HL,HL,HL,TM,HL,HL,HL,TR);
  239.     gotoxy(20,6);
  240.     writeln(VL,' ',place[1],' ',VL,' ',place[2],' ',VL,' ',place[3],' ',VL,' ',place[4],' ',VL);
  241.     gotoxy(20,7);
  242.     writeln(LM,HL,HL,HL,CR,HL,HL,HL,CR,HL,HL,HL,CR,HL,HL,HL,RM);
  243.     gotoxy(20,8);
  244.     writeln(VL,' ',place[5],' ',VL,' ',place[6],' ',VL,' ',place[7],' ',VL,' ',place[8],' ',VL);
  245.     gotoxy(20,9);
  246.     writeln(LM,HL,HL,HL,CR,HL,HL,HL,CR,HL,HL,HL,CR,HL,HL,HL,RM);
  247.     gotoxy(20,10);
  248.     writeln(VL,' ',place[9],' ',VL,' ',place[10],' ',VL,' ',place[11],' ',VL,' ',place[12],' ',VL);
  249.     gotoxy(20,11);
  250.     writeln(LM,HL,HL,HL,CR,HL,HL,HL,CR,HL,HL,HL,CR,HL,HL,HL,RM);
  251.     gotoxy(20,12);
  252.     writeln(VL,' ',place[13],' ',VL,' ',place[14],' ',VL,' ',place[15],' ',VL,' ',place[16],' ',VL);
  253.     gotoxy(20,13);
  254.     writeln(BL,HL,HL,HL,BM,HL,HL,HL,BM,HL,HL,HL,BM,HL,HL,HL,BR);
  255. end;
  256.  
  257. function PlayAgain:boolean;
  258. var ch : char;
  259. begin
  260.   DeleteLine(2,22);
  261.   gotoxy(20,21);
  262.   LowVideo;
  263.   write('Play again ? ');
  264.   NormVideo;
  265.   repeat
  266.     read(kbd,ch);
  267.     ch := upcase(ch);
  268.     if not (ch in ['Y','N']) then
  269.     begin
  270.       gotoxy(40,21);
  271.       write(#7,'Please press Y or N !');
  272.     end;
  273.   until ch in ['Y','N'];
  274.   DeleteLine(2,18);
  275.   DeleteLine(2,21);
  276.   if ch = 'N' then
  277.     begin
  278.       clrscr;
  279.       RestoreAll;
  280.       Halt;
  281.     end;
  282.   if ch = 'Y' then
  283.     PlayAgain := true
  284.   else
  285.     PlayAgain := false;
  286. end;
  287.  
  288. procedure Stop;
  289. begin
  290.   index := -1;
  291.   gotoxy(20,16);
  292.   writeln(#7,'I don`t believe that you can finish the game !       ');
  293.   DeleteLine(2,17);
  294.   finished := true;
  295. end;
  296.  
  297. procedure PossibleDirections;
  298. var r : integer;
  299. begin
  300.   result[1] := indicator -4;
  301.   result[2] := indicator +4;
  302.   result[3] := indicator +1;
  303.   result[4] := indicator -1;
  304.   for r := 1 to 4 do
  305.   if (result[r] >16 ) or (result[r] <1) then
  306.     result[r]:=-1;
  307.   case indicator of
  308.     4: result[3] := -1;
  309.     5: result[4] := -1;
  310.     8: result[3] := -1;
  311.     9: result[4] := -1;
  312.    12: result[3] := -1;
  313.    13: result[4] := -1;
  314.   end;
  315. end;
  316.  
  317. procedure Input;
  318. var
  319. wahl      : char;
  320. direction : integer;
  321.  
  322. begin
  323.   repeat
  324.     DeleteLine(2,17);
  325.     gotoxy(20,16);
  326.     LowVideo;
  327.     writeln('Which letter should be moved ? (Q = Quit)           ');
  328.     NormVideo;
  329.     repeat
  330.       DeleteLine(20,17);
  331.       gotoxy(20,17);
  332.       read(kbd,wahl);
  333.       wahl := upcase(wahl);
  334.       DeleteLine(2,18);
  335.       if not (wahl in ['Q','A'..'O'] )then
  336.       begin
  337.         gotoxy(20,18);
  338.         write(#7,'Please choose from A up to O or Q !           ');
  339.       end;
  340.     until wahl in ['Q','A'..'O'] ;
  341.     direction := -1;
  342.     if wahl = 'Q' then
  343.       begin
  344.         clrscr;
  345.         RestoreAll;
  346.         Halt;
  347.       end;
  348.     for i := 1 to 16 do
  349.       if place[i] = wahl then
  350.         indicator := i;
  351.     PossibleDirections;
  352.     for i := 1 to 4 do
  353.       if empty = result[i] then
  354.         direction := empty;
  355.     if direction = -1 then
  356.     begin
  357.       gotoxy(20,18);
  358.       write(#7,'You can`t move that letter yet !                      ');
  359.     end;
  360.   until direction <> -1;
  361.   place[direction] := place[indicator];
  362.   place[indicator] := ' ';
  363.   empty := indicator;
  364. end;
  365.  
  366. function managed : boolean;
  367. var ready : boolean;
  368.     sequence : string[18];
  369.     j : integer;
  370. begin
  371.   ready := false;
  372.   sequence := '';
  373.   for j := 1 to 16 do
  374.     sequence := sequence + place[j];
  375.   if sequence = 'ABCDEFGHIJKLMNO ' then
  376.     ready := true;
  377.   if ready = true then
  378.   begin
  379.     gotoxy(20,16); writeln('You managed it !                                     ');
  380.     number := (moves*100)/shuffl;
  381.     gotoxy(20,17);
  382.     writeln('You needed ',number:1:0,'% of the number of   ');
  383.     gotoxy(20,18);
  384.     writeln('moves the computer used to shuffle !       ');
  385.   end;
  386.   managed := ready;
  387. end;
  388.  
  389. procedure schuffle;
  390. var
  391. inp2  : string[5];
  392. inp,full,PossibleDir,code : integer;
  393. wrong : boolean;
  394. begin
  395.   gotoxy(20,16); writeln('How many times should I shuffle ?');
  396.   DeleteLine(54,16);
  397.   repeat
  398.     DeleteLine(20,17);
  399.     gotoxy(20,17);
  400.     readln(inp2);
  401.     val(inp2,shuffl,code);
  402.     if not ((shuffl>1) and (code=0) and (shuffl <201)) then
  403.     begin
  404.       DeleteLine(2,18);
  405.       DeleteLine(2,19);
  406.       gotoxy(20,18);
  407.       writeln(#7,'Please input an integer number between 2 and 200 !');
  408.     end;
  409.   until (shuffl > 1) and (code = 0) and (shuffl < 201);
  410.   DeleteLine(2,18);
  411.   gotoxy(20,19); writeln('Shuffling - please wait !  ');
  412.   for I := 1 to shuffl do
  413.   begin
  414.     repeat
  415.       repeat
  416.         wrong := false;
  417.         PossibleDir := round(random(4)+1);
  418.         if PossibleDir = OldDir then wrong := true;
  419.       until wrong = false;
  420.       indicator := empty;
  421.       PossibleDirections;
  422.     until result[PossibleDir] <> -1;
  423.     full := result[PossibleDir];
  424.     place[empty] := place[full];
  425.     place[full] := ' ';
  426.     empty := full;
  427.     ScreenSetUp;
  428.     if PossibleDir = 1 then OldDir := 2;
  429.     if PossibleDir = 2 then OldDir := 1;
  430.     if PossibleDir = 3 then OldDir := 4;
  431.     if PossibleDir = 4 then OldDir := 3;
  432.     gotoxy(40,23);
  433.     Writeln(i:3,' times shuffled! ');
  434.   end;
  435.   DeleteLine(2,19);
  436. end;
  437.  
  438. procedure Initialisation;
  439. begin
  440.   if again <> 2 then
  441.   begin
  442.     LowVideo;
  443.     gotoxy(44,6); writeln('Programmed by:');
  444.     NormVideo;
  445.     gotoxy(44,8); writeln('Konstantin Articus,');
  446.     gotoxy(44,9); writeln('West Germany.');
  447.     gotoxy(44,11); writeln('Converted to Microbee');
  448.     gotoxy(44,12); writeln('by A J Laughton, 1990');
  449.   end;
  450.   randomize;
  451.   OldDir := 0;
  452.   for i := 1 to 15 do
  453.   begin
  454.     place[i] := chr(64+i);
  455.   end;
  456.   place[16] := ' ';
  457.   finished := false;
  458.   empty := 16;
  459.   index := 0;
  460.   moves := 0;
  461.   ScreenSetUp;
  462.   gotoxy(40,23);
  463.   write(0:3,' times shuffled! ');
  464.   gotoxy(1,1);
  465. end;
  466.  
  467. begin   {Main Program starts here}
  468.   Bold;                 { Puts BOLD chr's in PCG ram }
  469.   BorderPCGs;           { Puts Border chr's in PCG ram }
  470.   Border;               { Draws the Border }
  471.   again := 1;
  472.   repeat
  473.     Initialisation;
  474.     again := 2;
  475.     schuffle;
  476.     repeat
  477.       moves := moves + 1;
  478.       Input;
  479.       if index <> -1 then
  480.       begin
  481.         ScreenSetUp;
  482.         finished := managed;
  483.         if moves = 500 then Stop;        { If you can't do it in 500 turns ...}
  484.       end
  485.       else finished := true;
  486.     until finished = true;
  487.   until PlayAgain = false;
  488. end.
  489.