home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug077.arc / SS.PAS < prev   
Pascal/Delphi Source File  |  1979-12-31  |  13KB  |  538 lines
  1. Program SilentSalesman;
  2. {$C-}
  3. Const
  4.   DemoDFactor = 0;
  5.   NormalDFactor = 300;
  6.   FFName = 'SS.FON';
  7.   FuncPort = $0C;
  8.   RegPort  = $0D;
  9.   {6545 register functions}
  10.   CharPosInLine      = 0;
  11.   NoOfCharsPerLine   = 1;
  12.   HorizSyncPos       = 2;
  13.   SyncInfo           = 3;
  14.   CharsPerFrame      = 4;
  15.   FracAmmount        = 5;
  16.   NoOfCharRows       = 6;
  17.   VertSyncPos        = 7;
  18.   ChipMode           = 8;
  19.   HeightOfChar       = 9;
  20.   CursorScanLineStart = 10;
  21.   CursorScanLineEnd   = 11;
  22.   FirstCharHi         = 12;
  23.   FirstCharLo         = 13;
  24.   CursPosHi           = 14;
  25.   CursPosLo           = 15;
  26.   {Others follow, but I cant be bothered}
  27.   StartLine : integer = 7;
  28.   CharSize = 16;
  29.   PredCharSize = 15;
  30.   PDest = 64;
  31.   MessLimit = $3000;
  32.  
  33.   Space = ' ';
  34.   Esc   = #27;
  35.   MaxAtt = 20;
  36. Type PREcord = Record
  37.        Num,
  38.        Delay : integer;
  39.      End;
  40.     MessType = Array[ 1..MessLimit ] of Char;
  41.     FArrayType = Array[ 0..MaxAtt ] of Integer;
  42.     PArrayType = Array[ 0..MaxAtt ] of PRecord;
  43. Var ScrEnd        : Byte absolute $F780;
  44.     Scr           : Array[ 0..$7FF ] of byte absolute $F000;
  45.     Col           : Array[ 0..$7FF ] of byte absolute $F800;
  46.     FPCG          : Byte absolute $F820;
  47.     StartPosArray : Array[ 0..CharSize ] of integer;
  48.     Line1Start    : Byte absolute $F000;
  49.     Line2Start    : Byte absolute $F050;
  50.     FArray        : Array[ 0..127 , 0..15 ] of byte;
  51.     PCGArray      : Array[ 0..127 , 0..15 ] of byte absolute $F000;
  52.     FlashCount,
  53.     PauseCount    : integer;
  54.     Mess          : MessType;
  55.     LengthMess    : integer;
  56.     TotalFlashes,
  57.     TotalPauses,
  58.     DFActor       : integer;
  59.     PArray        : PArrayType;
  60.     FOnArray,
  61.     FOffArray     : FArrayType;
  62.  
  63.     Premium       : Boolean;
  64.  
  65.  
  66. Procedure CalcPLetterNum;
  67. Var i : integer;
  68. Begin
  69.   For i:= 1 to TotalPauses do
  70.     Begin
  71.       PArray[ i ].Num := PArray[ i ].Num + 10;
  72.       If PArray[ i ].Num > LengthMess then
  73.         PArray[ i ].Num := PArray[ i ].Num - LengthMess;
  74.     End;
  75. End;
  76.  
  77. Procedure InError( ErrorNum : integer);
  78. Var ErrStr : String[ 80 ];
  79.     I      : Integer;
  80. Begin
  81.   ErrStr := '';
  82.   Case ErrorNum of
  83.     1 : ErrStr := 'Invalid character in input file';
  84.     2 : ErrStr := 'A number from 1 to 9 must follow a ^P';
  85.     3 : ErrStr := 'File too big';
  86.   End;
  87.   ClrScr;
  88.   Gotoxy( 1,10 );
  89.   Writeln('Error in input file.');
  90.   Writeln( 'Error occured at printable character no. ' , LengthMess );
  91.   Writeln( ErrStr );
  92.   If ErrorNum in [ 1,2 ] then
  93.     Begin
  94.       Writeln('Message until error was ...');
  95.       For i:= 1 to LengthMess do Write( Mess[ i ] );
  96.     End;
  97.   Halt;
  98. End;
  99.  
  100. Procedure Wait;
  101. Var Ch : char;
  102. Begin
  103.   Read( Kbd , Ch );
  104. End;
  105.  
  106. Procedure ProcessInFile;
  107. Const DefName = 'SS.TXT';
  108. Type FType = ( Fon , Foff );
  109. Var InFile : text;
  110.     InName : String[ 14 ];
  111.     InStr  : String[ 255 ];
  112.     i,
  113.     Err,
  114.     FonCtr,
  115.     FOffCtr : integer;
  116.     NextFtype : FType;
  117. Procedure GetInName;
  118. Begin
  119.   If ParamCount = 0 then
  120.     InName := DefName
  121.   Else
  122.     InName := ParamStr( 1 );
  123. End;
  124.  
  125. Begin
  126.   GetInName;
  127.   Mess[ 1 ] := SPace;
  128.   LengthMess := 1;
  129.   NextFType := Fon;
  130.   Assign( InFile , InName );
  131.   {$I-}
  132.   Reset( INFile );
  133.   {$I+}
  134.   If IOResult <> 0 then
  135.     Begin
  136.       ClrScr;
  137.       Gotoxy(1,11);
  138.       Writeln('Text file not found ( ' , InName , ' )');
  139.       Halt;
  140.     End;
  141.   FonCtr := 0;
  142.   FOffCtr := 0;
  143.   TotalPauses := 0;
  144.   While ( Not EOF( InFile ) ) and ( LengthMess <= MessLimit ) do
  145.     Begin
  146.       Readln( InFile , InStr );
  147.       I := 0;
  148.       While ( i < Length( Instr ) ) and  ( LengthMess <= MessLimit ) do
  149.         Begin
  150.           i := Succ( i );
  151.           InStr[ i ] := Chr( Ord( InStr[ i ] ) and $7F );
  152.           If InStr[ i ] in [ ' ' .. '~'] then
  153.             Begin
  154.               LengthMess := Succ( LengthMess );
  155.               Mess[ LengthMess ] := InStr[ i ];
  156.             End
  157.           Else
  158.             If InStr[ i ] = ^F then
  159.               If FonCtr = FOffCtr then
  160.                 Begin
  161.                   FOnCtr := Succ( FOnCtr );
  162.                   FOnArray[ FOnCtr ] := LengthMess ;
  163.                 End
  164.               Else
  165.                 Begin
  166.                   FOffCtr := Succ( FoffCtr );
  167.                   FOffArray[ FOffCtr ] := LengthMess;
  168.                 End
  169.             Else
  170.               If InStr[ i ] = ^P then
  171.                 Begin
  172.                   TotalPauses := Succ( TotalPauses );
  173.                   PArray[ TotalPauses ].Num := LengthMess;
  174.                   I := Succ( i );
  175.                   If I > Length( InStr ) then InError( 2 );
  176.                   InStr[ i ] := Chr( Ord( InStr[ i ] ) and $7F );
  177.                   If Not( InStr[ i ] in ['1'..'9'] ) then InError( 2 )
  178.                   Else
  179.                       Val( InStr[ i ] , PArray[ TotalPauses ].Delay , Err );
  180.                 End
  181.               Else
  182.                 InError( 1 );
  183.         End;
  184.     End;
  185.   If LengthMess >= MessLimit then InError( 3 );
  186.   If ( FOnCtr <> FOffCtr ) then FOffArray[ FonCtr ] := LengthMess;
  187.   TotalFlashes := FOnCtr;
  188.   For i := LengthMess+1 to LengthMess+5 do Mess[ i ] := Space;
  189.   LengthMess := LengthMess + 5;
  190.   CalcPLEtterNum;
  191. End;
  192.  
  193.  
  194. Procedure SetFunct( I : integer );
  195. Begin
  196.   Port[ FuncPort ] := I;
  197. End;
  198.  
  199. Procedure SetReg( I : integer );
  200. Begin
  201.   Port[ RegPort ] := I;
  202. End;
  203.  
  204. Procedure SetUpFArray;
  205. Var i , j : integer;
  206. Begin
  207.   StartLine := StartLine - 2;
  208.   SetFunct( FirstCharHi );
  209.   SetReg( 0 );
  210.   Port[ $0B ] := 1;
  211.   For i:= 0 to 127 do
  212.     For j:= 0 to 15 do
  213.       FArray[ i , j ] := {Not}( PCGArray[ i , j ] );
  214.   Port[ $0B ] := 0;
  215. End;
  216.  
  217. Procedure ReadFont;
  218. Var FFile : file;
  219. Begin
  220.   Assign( FFile , FFName );
  221.   {$I-}
  222.   Reset( FFile );
  223.   {$I+}
  224.   If IOResult <> 0 then
  225.     Begin
  226.       Writeln(^G);
  227.       SetUpFArray;
  228.       Exit;
  229.     End;
  230.   BlockRead( FFile , FArray , 16 );
  231. End;
  232.  
  233. Procedure SetUpPosArray;
  234. Var i : integer;
  235. Begin
  236.   StartPosArray[ 0 ] := 80 * ( StartLine - 1 ) - 1;
  237.   For i:= 1 to Pred( CharSize ) do StartPosArray[ i ] := StartPosArray[ i - 1 ] + 80;
  238. End;
  239.  
  240. Procedure SetUpPCGs;
  241. Var i : integer;
  242. Begin
  243.   For i:= $F800 to $F80F do Mem[ i ] := 0;{128}
  244.   For i:= $F810 to $F81F do mem[ i ] := $FF;   {129}
  245.   For i:= $F820 to $F82F do mem[ i ] := $FF; {Flashing char}{130}
  246.   For i:= $F830 to $F833 do mem[ i ] := 0;For i:= $F834 to $F836 do mem[ i ] := $FF;For i:= $F837 to $F83B do mem[ i ] := 0;
  247. End;
  248.  
  249. Procedure FlashOn;
  250. Begin
  251.   FillChar( FPCG , 11 , $FF );
  252. End;
  253.  
  254. Procedure FlashOff;
  255. Begin
  256.   FillChar( FPCG , 11 , $00 );
  257. End;
  258.  
  259.  
  260. Procedure RemoveCPMCursor;
  261. Var i : integer;
  262. Begin
  263.   For i:= $FA00 to $FA10 do mem[ i ] := $0;
  264. End;
  265.  
  266. Procedure RestoreCPMCursor;
  267. Var i : integer;
  268. Begin
  269.   For i:= $FA00 to $FA10 do mem[ i ] := $FF;
  270.  End;
  271.  
  272. Procedure ClearAllScreen;
  273. Begin
  274.   FillChar( Line1Start , $800 , 32 );
  275. End;
  276.  
  277. Procedure CheckFlash( ChNum : integer ; Var Flashing : Boolean );
  278. Begin
  279.   If ( TotalFlashes > 0 ) and ( ChNum = FOnArray[ FlashCount ] ) then
  280.     Flashing := True;
  281.   If ChNum = FOffArray[ FlashCount ] then
  282.     Begin
  283.       Flashing:= False;
  284.       FlashCount := Succ( FlashCount );
  285.       If FlashCount > TotalFlashes then FlashCount := 1;
  286.     End;
  287. End;
  288.  
  289. Procedure CheckPause( Bit : byte ; Var Paused : Boolean ; ChNum : integer ; Var PauseIter : integer);
  290. Var i : integer;
  291. Begin
  292.   If Not Paused then
  293.     Begin
  294.       If ( TotalPauses > 0 ) and ( PArray[ PauseCount ].Num = ChNum ) and ( Bit = $01 ) then
  295.         Begin
  296.           PauseIter := 16 * PArray[ PauseCount ].Delay ;
  297.           PauseCount := Succ( PauseCount );
  298.           If PauseCount > TotalPauses then PauseCount := 1;
  299.           Paused := True;
  300.  
  301.         End;
  302.     End
  303.   Else
  304.     Begin
  305.       PauseIter := Pred( PauseIter );
  306.       For i := 1 to 4 * DFactor do;
  307.       If PauseIter = 0 then Paused := False;
  308.     End;
  309. End;
  310.  
  311. Procedure SetUpColRam;
  312. Begin
  313.   Port[ $8 ] := $40;
  314. End;
  315.  
  316. Procedure SetUpPCGRam;
  317. Begin
  318.   Port[ $8 ] := 0;
  319. End;
  320.  
  321. Procedure Am_I_a_Colour;
  322. Begin
  323.   Mem[ $F800 ] := 0;
  324.   SetUpColRam;
  325.   Mem[ $F800 ] := $FF;
  326.   SetUpPCGRam;
  327.   Premium := Mem[ $F800 ] = 0;
  328. End;
  329.  
  330. Procedure Beep;
  331. Var i : integer;
  332. Begin
  333.   Port[ 2 ] := $FF;
  334.   For i:= 1 to DFactor div 10 do;
  335.   Port[ 2 ] := 0;
  336. End;
  337.  
  338. Function InRetrace : boolean;
  339. Begin
  340.   InRetrace := ( Port[ FuncPort ] and $20 ) <> 0;
  341. End;
  342.  
  343. Procedure ModInt( Var Int : integer );
  344. Begin
  345.   Int := Int and $7FF;
  346. End;
  347.  
  348. Procedure ScrollScreen( Var Mess : MessType ; LengthMess : integer ; Demo : boolean);
  349. Var j , k , Bit , FCtr : Byte;
  350.     Flashing,
  351.     FOn,
  352.     Stopped,
  353.     Paused : Boolean;
  354.     Ch : Char;
  355.     i,
  356.     ChNum,
  357.     Color,
  358.     PosToPut,
  359.     P2,
  360.     P2Start,
  361.     PauseIter : integer;
  362. Begin
  363.   Color := Random( 7 ) + 1;
  364.   Gotoxy( 1,1 );
  365.   If Premium then
  366.     Begin
  367.       SetUpColRam;
  368.       FillChar( Col , $7FF , Color );
  369.     End;
  370.   SetUpPCGRam;
  371.   FlashCount := 1;
  372.   PauseCount := 1;
  373.   Stopped := False;
  374.   FOn := False;
  375.   FCtr := 0;
  376.   Paused := False;
  377.   Flashing := False;
  378.   P2Start := StartPosArray[ 0 ] - $50;
  379.   ChNum := 1;
  380.   Repeat
  381.       i := 0;
  382.       While ( i < $800 ) and ( Not Stopped ) do
  383.         Begin
  384.           i := Succ( i );
  385.           Bit := 1 shl ( 7 -( ( i-1 ) mod 8 ) );
  386.           P2 := P2Start + i;
  387.           ModInt( p2 );
  388.           Scr[ P2 ] := 32;
  389.           SetFunct( FirstCharHi );
  390.           SetReg( $20 or Hi( i ) );
  391.           SetFunct( FirstCharLo );
  392.           SetReg( Lo( i ) );
  393.           Repeat Until Not InRetrace;
  394.           Repeat Until InRetrace;
  395.           For k := 0 to PredCharSize do
  396.             begin
  397.               PosToPut := StartPosArray[ k ] + i;
  398.               ModInt( PosToPut );
  399.               If Premium then
  400.                 Begin
  401.                   SetUpColRam;
  402.                   Col[ PosToPut ] := Color;
  403.                   SetUpPCGRam;
  404.                 End;
  405.               If ( ( k = PredCharSize) and Flashing ) or
  406.                  ( ( FArray[ ( Ord( Mess[ ChNum ] ) ) , K ] and Bit ) <> 0 ) then
  407.                 If Flashing then
  408.                   Scr[ PosToPut ] := 130
  409.                 Else
  410.                   Scr[ PosToPut ] := 129
  411.               Else
  412.                 Scr[ PosToPut ] := 128;
  413.             end;
  414.  
  415.           Repeat
  416.             FCtr := Succ( FCtr );
  417.             If FCtr = 8 then
  418.               Begin
  419.                 FCtr := 0;
  420.                 CheckFlash( ChNum , Flashing );
  421.                 If FOn then
  422.                   Begin
  423.                     FlashOff;
  424.                     FOn := False;
  425.                   End
  426.                 Else
  427.                   Begin
  428.                     FlashOn;
  429.                     FOn := True;
  430.                   End;
  431.               End;
  432.             CheckPause( Bit , Paused , ChNum , PauseIter );
  433.             If KeyPressed then
  434.               Begin
  435.                 Read( kbd , Ch );
  436.                 Stopped := ( Ch = Esc );
  437.                 If Ch = ^S then
  438.                    If DFactor > 0 then
  439.                      Begin
  440.                        DFactor := DFactor - 100;
  441.                        Beep;
  442.                      End;
  443.                 If Ch = ^D then
  444.                   If DFactor < 600 then
  445.                     Begin
  446.                       DFactor := DFactor + 100;
  447.                       Beep;
  448.                     End;
  449.               End;
  450.           Until Not Paused;
  451.           If Bit = $01 then
  452.               Begin
  453.                 ChNum := Succ( ChNum );
  454.                 If ChNum > LengthMess then ChNum := 1;
  455.                 If Mess[ ChNum ] = SPace then Color := Random( 7 ) + 1;
  456.               End;
  457.  
  458.          For j := 1 to DFactor do;
  459.          Stopped := Stopped or ( demo and ( ChNum = LengthMess ) );
  460.        End;
  461.      SetFunct( FirstCharLo );
  462.    Until demo or Stopped;
  463. End;
  464.  
  465. Procedure DemoMode;
  466. Var Str : String[ 255 ];
  467.     Mess2 : MessType;
  468.     Len2,
  469.     TTotalPauses,
  470.     TTotalFlashes,
  471.     i   : integer;
  472.     TFonArray ,
  473.     TFoffArray : FArrayType;
  474. Begin
  475.   TFonArray := FOnArray;
  476.   TFoffArray := FoffArray;
  477.   TTotalFlashes := TotalFlashes;
  478.   TTotalPauses := TotalPauses;
  479.   DFactor := DemoDFactor;
  480.   Str := 'Silent Salesman program.  Written by MARK HAMMOND.  This machine is ';
  481.   If Not Premium then
  482.     Begin
  483.       TotalFlashes := 2;
  484.       Str := Str + 'not ';
  485.     End
  486.   Else
  487.     TotalFLashes := 1;
  488.   FOnArray[ 1 ] := 37;
  489.   FOffArray[ 1 ] := 49;
  490.   FOnArray[ 2 ] := 68;
  491.   FOffArray[ 2 ] := 71;
  492.   TotalPauses := 0;
  493.   Str := Str + 'a premium            ';
  494.   Move( Str[1] , Mess2 , Length( Str ) );
  495.   Len2 := Length( Str );
  496.   ScrollScreen( Mess2 , Len2, true );
  497.   FonArray := TFOnArray;
  498.   FoffArray := TFoffArray;
  499.   TotalFlashes := TTotalFlashes;
  500.   TotalPauses := TTotalPauses;
  501.   ClearAllScreen;
  502. End;
  503.  
  504. Procedure DoDisplay;
  505. Var i : integer;
  506. Begin
  507.   DFactor := NormalDFactor;
  508.   ScrollScreen( MEss , LengthMess , false );
  509. End;
  510.  
  511. Begin
  512.   ProcessInFile;
  513.   Am_I_a_Colour;
  514.   Randomize;
  515.   ClearAllScreen;
  516.   RemoveCPMCursor;
  517.   ReadFont;
  518.   SetUpPCGs;
  519.   SetUpPosArray;
  520.  
  521.   DemoMode;
  522.   DoDisplay;
  523.  
  524.   SetFunct( FirstCharHi );
  525.   SetReg( $20 );
  526.   SetFunct( FirstCharLo );
  527.   SetReg( 0 );
  528.  
  529.   ClrScr;
  530.   Gotoxy( 35 , 12 );
  531.   Write('Good-bye');
  532.  
  533.   RestoreCPMCursor;
  534. End.
  535.  
  536.  
  537.  
  538.