home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CP/M
/
CPM_CDROM.iso
/
mbug
/
mbug077.arc
/
SS.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1979-12-31
|
13KB
|
538 lines
Program SilentSalesman;
{$C-}
Const
DemoDFactor = 0;
NormalDFactor = 300;
FFName = 'SS.FON';
FuncPort = $0C;
RegPort = $0D;
{6545 register functions}
CharPosInLine = 0;
NoOfCharsPerLine = 1;
HorizSyncPos = 2;
SyncInfo = 3;
CharsPerFrame = 4;
FracAmmount = 5;
NoOfCharRows = 6;
VertSyncPos = 7;
ChipMode = 8;
HeightOfChar = 9;
CursorScanLineStart = 10;
CursorScanLineEnd = 11;
FirstCharHi = 12;
FirstCharLo = 13;
CursPosHi = 14;
CursPosLo = 15;
{Others follow, but I cant be bothered}
StartLine : integer = 7;
CharSize = 16;
PredCharSize = 15;
PDest = 64;
MessLimit = $3000;
Space = ' ';
Esc = #27;
MaxAtt = 20;
Type PREcord = Record
Num,
Delay : integer;
End;
MessType = Array[ 1..MessLimit ] of Char;
FArrayType = Array[ 0..MaxAtt ] of Integer;
PArrayType = Array[ 0..MaxAtt ] of PRecord;
Var ScrEnd : Byte absolute $F780;
Scr : Array[ 0..$7FF ] of byte absolute $F000;
Col : Array[ 0..$7FF ] of byte absolute $F800;
FPCG : Byte absolute $F820;
StartPosArray : Array[ 0..CharSize ] of integer;
Line1Start : Byte absolute $F000;
Line2Start : Byte absolute $F050;
FArray : Array[ 0..127 , 0..15 ] of byte;
PCGArray : Array[ 0..127 , 0..15 ] of byte absolute $F000;
FlashCount,
PauseCount : integer;
Mess : MessType;
LengthMess : integer;
TotalFlashes,
TotalPauses,
DFActor : integer;
PArray : PArrayType;
FOnArray,
FOffArray : FArrayType;
Premium : Boolean;
Procedure CalcPLetterNum;
Var i : integer;
Begin
For i:= 1 to TotalPauses do
Begin
PArray[ i ].Num := PArray[ i ].Num + 10;
If PArray[ i ].Num > LengthMess then
PArray[ i ].Num := PArray[ i ].Num - LengthMess;
End;
End;
Procedure InError( ErrorNum : integer);
Var ErrStr : String[ 80 ];
I : Integer;
Begin
ErrStr := '';
Case ErrorNum of
1 : ErrStr := 'Invalid character in input file';
2 : ErrStr := 'A number from 1 to 9 must follow a ^P';
3 : ErrStr := 'File too big';
End;
ClrScr;
Gotoxy( 1,10 );
Writeln('Error in input file.');
Writeln( 'Error occured at printable character no. ' , LengthMess );
Writeln( ErrStr );
If ErrorNum in [ 1,2 ] then
Begin
Writeln('Message until error was ...');
For i:= 1 to LengthMess do Write( Mess[ i ] );
End;
Halt;
End;
Procedure Wait;
Var Ch : char;
Begin
Read( Kbd , Ch );
End;
Procedure ProcessInFile;
Const DefName = 'SS.TXT';
Type FType = ( Fon , Foff );
Var InFile : text;
InName : String[ 14 ];
InStr : String[ 255 ];
i,
Err,
FonCtr,
FOffCtr : integer;
NextFtype : FType;
Procedure GetInName;
Begin
If ParamCount = 0 then
InName := DefName
Else
InName := ParamStr( 1 );
End;
Begin
GetInName;
Mess[ 1 ] := SPace;
LengthMess := 1;
NextFType := Fon;
Assign( InFile , InName );
{$I-}
Reset( INFile );
{$I+}
If IOResult <> 0 then
Begin
ClrScr;
Gotoxy(1,11);
Writeln('Text file not found ( ' , InName , ' )');
Halt;
End;
FonCtr := 0;
FOffCtr := 0;
TotalPauses := 0;
While ( Not EOF( InFile ) ) and ( LengthMess <= MessLimit ) do
Begin
Readln( InFile , InStr );
I := 0;
While ( i < Length( Instr ) ) and ( LengthMess <= MessLimit ) do
Begin
i := Succ( i );
InStr[ i ] := Chr( Ord( InStr[ i ] ) and $7F );
If InStr[ i ] in [ ' ' .. '~'] then
Begin
LengthMess := Succ( LengthMess );
Mess[ LengthMess ] := InStr[ i ];
End
Else
If InStr[ i ] = ^F then
If FonCtr = FOffCtr then
Begin
FOnCtr := Succ( FOnCtr );
FOnArray[ FOnCtr ] := LengthMess ;
End
Else
Begin
FOffCtr := Succ( FoffCtr );
FOffArray[ FOffCtr ] := LengthMess;
End
Else
If InStr[ i ] = ^P then
Begin
TotalPauses := Succ( TotalPauses );
PArray[ TotalPauses ].Num := LengthMess;
I := Succ( i );
If I > Length( InStr ) then InError( 2 );
InStr[ i ] := Chr( Ord( InStr[ i ] ) and $7F );
If Not( InStr[ i ] in ['1'..'9'] ) then InError( 2 )
Else
Val( InStr[ i ] , PArray[ TotalPauses ].Delay , Err );
End
Else
InError( 1 );
End;
End;
If LengthMess >= MessLimit then InError( 3 );
If ( FOnCtr <> FOffCtr ) then FOffArray[ FonCtr ] := LengthMess;
TotalFlashes := FOnCtr;
For i := LengthMess+1 to LengthMess+5 do Mess[ i ] := Space;
LengthMess := LengthMess + 5;
CalcPLEtterNum;
End;
Procedure SetFunct( I : integer );
Begin
Port[ FuncPort ] := I;
End;
Procedure SetReg( I : integer );
Begin
Port[ RegPort ] := I;
End;
Procedure SetUpFArray;
Var i , j : integer;
Begin
StartLine := StartLine - 2;
SetFunct( FirstCharHi );
SetReg( 0 );
Port[ $0B ] := 1;
For i:= 0 to 127 do
For j:= 0 to 15 do
FArray[ i , j ] := {Not}( PCGArray[ i , j ] );
Port[ $0B ] := 0;
End;
Procedure ReadFont;
Var FFile : file;
Begin
Assign( FFile , FFName );
{$I-}
Reset( FFile );
{$I+}
If IOResult <> 0 then
Begin
Writeln(^G);
SetUpFArray;
Exit;
End;
BlockRead( FFile , FArray , 16 );
End;
Procedure SetUpPosArray;
Var i : integer;
Begin
StartPosArray[ 0 ] := 80 * ( StartLine - 1 ) - 1;
For i:= 1 to Pred( CharSize ) do StartPosArray[ i ] := StartPosArray[ i - 1 ] + 80;
End;
Procedure SetUpPCGs;
Var i : integer;
Begin
For i:= $F800 to $F80F do Mem[ i ] := 0;{128}
For i:= $F810 to $F81F do mem[ i ] := $FF; {129}
For i:= $F820 to $F82F do mem[ i ] := $FF; {Flashing char}{130}
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;
End;
Procedure FlashOn;
Begin
FillChar( FPCG , 11 , $FF );
End;
Procedure FlashOff;
Begin
FillChar( FPCG , 11 , $00 );
End;
Procedure RemoveCPMCursor;
Var i : integer;
Begin
For i:= $FA00 to $FA10 do mem[ i ] := $0;
End;
Procedure RestoreCPMCursor;
Var i : integer;
Begin
For i:= $FA00 to $FA10 do mem[ i ] := $FF;
End;
Procedure ClearAllScreen;
Begin
FillChar( Line1Start , $800 , 32 );
End;
Procedure CheckFlash( ChNum : integer ; Var Flashing : Boolean );
Begin
If ( TotalFlashes > 0 ) and ( ChNum = FOnArray[ FlashCount ] ) then
Flashing := True;
If ChNum = FOffArray[ FlashCount ] then
Begin
Flashing:= False;
FlashCount := Succ( FlashCount );
If FlashCount > TotalFlashes then FlashCount := 1;
End;
End;
Procedure CheckPause( Bit : byte ; Var Paused : Boolean ; ChNum : integer ; Var PauseIter : integer);
Var i : integer;
Begin
If Not Paused then
Begin
If ( TotalPauses > 0 ) and ( PArray[ PauseCount ].Num = ChNum ) and ( Bit = $01 ) then
Begin
PauseIter := 16 * PArray[ PauseCount ].Delay ;
PauseCount := Succ( PauseCount );
If PauseCount > TotalPauses then PauseCount := 1;
Paused := True;
End;
End
Else
Begin
PauseIter := Pred( PauseIter );
For i := 1 to 4 * DFactor do;
If PauseIter = 0 then Paused := False;
End;
End;
Procedure SetUpColRam;
Begin
Port[ $8 ] := $40;
End;
Procedure SetUpPCGRam;
Begin
Port[ $8 ] := 0;
End;
Procedure Am_I_a_Colour;
Begin
Mem[ $F800 ] := 0;
SetUpColRam;
Mem[ $F800 ] := $FF;
SetUpPCGRam;
Premium := Mem[ $F800 ] = 0;
End;
Procedure Beep;
Var i : integer;
Begin
Port[ 2 ] := $FF;
For i:= 1 to DFactor div 10 do;
Port[ 2 ] := 0;
End;
Function InRetrace : boolean;
Begin
InRetrace := ( Port[ FuncPort ] and $20 ) <> 0;
End;
Procedure ModInt( Var Int : integer );
Begin
Int := Int and $7FF;
End;
Procedure ScrollScreen( Var Mess : MessType ; LengthMess : integer ; Demo : boolean);
Var j , k , Bit , FCtr : Byte;
Flashing,
FOn,
Stopped,
Paused : Boolean;
Ch : Char;
i,
ChNum,
Color,
PosToPut,
P2,
P2Start,
PauseIter : integer;
Begin
Color := Random( 7 ) + 1;
Gotoxy( 1,1 );
If Premium then
Begin
SetUpColRam;
FillChar( Col , $7FF , Color );
End;
SetUpPCGRam;
FlashCount := 1;
PauseCount := 1;
Stopped := False;
FOn := False;
FCtr := 0;
Paused := False;
Flashing := False;
P2Start := StartPosArray[ 0 ] - $50;
ChNum := 1;
Repeat
i := 0;
While ( i < $800 ) and ( Not Stopped ) do
Begin
i := Succ( i );
Bit := 1 shl ( 7 -( ( i-1 ) mod 8 ) );
P2 := P2Start + i;
ModInt( p2 );
Scr[ P2 ] := 32;
SetFunct( FirstCharHi );
SetReg( $20 or Hi( i ) );
SetFunct( FirstCharLo );
SetReg( Lo( i ) );
Repeat Until Not InRetrace;
Repeat Until InRetrace;
For k := 0 to PredCharSize do
begin
PosToPut := StartPosArray[ k ] + i;
ModInt( PosToPut );
If Premium then
Begin
SetUpColRam;
Col[ PosToPut ] := Color;
SetUpPCGRam;
End;
If ( ( k = PredCharSize) and Flashing ) or
( ( FArray[ ( Ord( Mess[ ChNum ] ) ) , K ] and Bit ) <> 0 ) then
If Flashing then
Scr[ PosToPut ] := 130
Else
Scr[ PosToPut ] := 129
Else
Scr[ PosToPut ] := 128;
end;
Repeat
FCtr := Succ( FCtr );
If FCtr = 8 then
Begin
FCtr := 0;
CheckFlash( ChNum , Flashing );
If FOn then
Begin
FlashOff;
FOn := False;
End
Else
Begin
FlashOn;
FOn := True;
End;
End;
CheckPause( Bit , Paused , ChNum , PauseIter );
If KeyPressed then
Begin
Read( kbd , Ch );
Stopped := ( Ch = Esc );
If Ch = ^S then
If DFactor > 0 then
Begin
DFactor := DFactor - 100;
Beep;
End;
If Ch = ^D then
If DFactor < 600 then
Begin
DFactor := DFactor + 100;
Beep;
End;
End;
Until Not Paused;
If Bit = $01 then
Begin
ChNum := Succ( ChNum );
If ChNum > LengthMess then ChNum := 1;
If Mess[ ChNum ] = SPace then Color := Random( 7 ) + 1;
End;
For j := 1 to DFactor do;
Stopped := Stopped or ( demo and ( ChNum = LengthMess ) );
End;
SetFunct( FirstCharLo );
Until demo or Stopped;
End;
Procedure DemoMode;
Var Str : String[ 255 ];
Mess2 : MessType;
Len2,
TTotalPauses,
TTotalFlashes,
i : integer;
TFonArray ,
TFoffArray : FArrayType;
Begin
TFonArray := FOnArray;
TFoffArray := FoffArray;
TTotalFlashes := TotalFlashes;
TTotalPauses := TotalPauses;
DFactor := DemoDFactor;
Str := 'Silent Salesman program. Written by MARK HAMMOND. This machine is ';
If Not Premium then
Begin
TotalFlashes := 2;
Str := Str + 'not ';
End
Else
TotalFLashes := 1;
FOnArray[ 1 ] := 37;
FOffArray[ 1 ] := 49;
FOnArray[ 2 ] := 68;
FOffArray[ 2 ] := 71;
TotalPauses := 0;
Str := Str + 'a premium ';
Move( Str[1] , Mess2 , Length( Str ) );
Len2 := Length( Str );
ScrollScreen( Mess2 , Len2, true );
FonArray := TFOnArray;
FoffArray := TFoffArray;
TotalFlashes := TTotalFlashes;
TotalPauses := TTotalPauses;
ClearAllScreen;
End;
Procedure DoDisplay;
Var i : integer;
Begin
DFactor := NormalDFactor;
ScrollScreen( MEss , LengthMess , false );
End;
Begin
ProcessInFile;
Am_I_a_Colour;
Randomize;
ClearAllScreen;
RemoveCPMCursor;
ReadFont;
SetUpPCGs;
SetUpPosArray;
DemoMode;
DoDisplay;
SetFunct( FirstCharHi );
SetReg( $20 );
SetFunct( FirstCharLo );
SetReg( 0 );
ClrScr;
Gotoxy( 35 , 12 );
Write('Good-bye');
RestoreCPMCursor;
End.