[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]
Program Viewit;
{$A-,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X+}
{$M $800,0,655000}
Uses Crt, DOS, Swunit, UmbHeap;
{^^^^^^^This Unit is in SWAG! Wish I can Find a XMS
one that can do the Same}
Type
TextMem = Array [1..15000] Of ^String;
BString = String [32];
Var
NName : String [14];
FileVar: Text;
FText : TextMem;
Lines : Integer;
Last : Integer;
OneLine, Temp, SString: BString;
Procedure ShowColor (S : String);
Var
I: Byte;
Begin
For I := 1 To Length (S)
Do Begin
Case S [I] Of
'0'..'9' : TextColor (LightCyan);
'A'..'Z' : TextColor (LightGray); {Changes Charater Colors in the
File} 'a'..'z' : TextColor (White); {Kinda Cool}
#9: Write (' ': 8);
Else TextColor (3);
End;
If S [I] <> #9 Then Write (S [I] );
End;
I := 79 - Length (S); Write (' ': I);
End;
Procedure Init (N: String);
Var F: Text;
S: String;
Begin
Extend_Heap;
Curoff;
FillChar ( FText, SizeOf (FText), 0 );
Lines := 0;
Assign ( f, N );
(*$I-*)
Reset ( f );
(*$I+*)
If IOResult <> 0 Then Exit;
While ( Not EoF ( F ) )
And ( MaxAvail > 80 )
Do
Begin
Inc ( Lines );
ReadLn ( F, S );
If Length (S) > 79
Then S [0] := #79;
GetMem ( FText [Lines], 1 + Length (S) );
FText [Lines]^ := S;
End;
Last := Lines;
Close ( F );
End;
{Ok NOW this Shearch KINDA Works ...Still Working On it!
If I dont hope someone can improv on it..}
Procedure Ucase (Var S: BString);
Var
I: Integer;
Begin
For I := 1 To Length (S) Do
S [I] := UpCase (S [I] );
End;
Procedure LookFor (R: String);
Var
I: Integer;
S: BString;
Begin
For I := 1 To Length (S) Do
S [I] := UpCase (S [I] );
Begin
GotoXY (2, 1);
Assign (FileVar, R);
Repeat
WriteLn;
GotoXY (2, 1);
Reset (FileVar);
ClrEol;
TextAttr := 116; Write ('Search for? (Enter to quit) ');
ReadLn (SString);
If Length (SString) > 0 Then
Begin
Ucase (SString);
Lines := 0;
While Not EoF (FileVar) Do
Begin
TextAttr := 112;
ReadLn (FileVar, OneLine);
Inc (Lines);
Temp := OneLine;
Ucase (Temp);
If Pos (SString, Temp) > 0
Then WriteLn (Lines: 3, ': ', OneLine)
End
End
Until Length (SString) = 0;
GotoXY (1, 1);
ClrEol;
End;
End;
Procedure ScrS (N: String);
Var CH : Char;
count: Integer;
Begin
Rot;
TextAttr := $70; (* Colors For Line 1 & 25 *)
ClrScr;
GotoXY ( 2, 1);
Write ('F3=Find F12=Screen Saver ');
GotoXY ( 2, 25);
While Pos ('\', N) > 0 Do Delete (n, 1, 1);
For count := 1 To Length (N) Do N [count] := UpCase (n [count] );
Write ('File: ', N, ', ', Last, ' Lines, ');
Write ( MemAvail, ' Bytes free.');
GotoXY (63, 25); Write ('Lines: ');
count := 1;
End;
Procedure Display (N: String);
Var CH : Char;
count: Integer;
Procedure Update;
Var Y, i: Integer;
Begin
If count > ( Last - 22 )
Then count := last - 22;
If count < 1
Then count := 1;
Y := 2;
For i := count To count + 22 Do
Begin
GotoXY (1, Y);
ClrEol;
Inc ( Y );
If i <= Last Then ShowColor ( FText [i]^ ); {Displays File}
End;
TextAttr := $74; (* Colors for Counter *)
GotoXY (70, 25);
If count + 23 > Last
Then Write (Last)
Else Write (count + 22);
ClrEol
End;
Begin
TextAttr := $70; (* Colors For Line 1 & 25 *)
ClrScr;
GotoXY ( 2, 1);
Write ('F3=Find F12=Screen Saver ');
{Write (' '); }
GotoXY ( 2, 25);
While Pos ('\', N) > 0 Do Delete (n, 1, 1);
For count := 1 To Length (N) Do N [count] := UpCase (n [count] );
Write ('File: ', N, ', ', Last, ' Lines, ');
Write ( MemAvail, ' Bytes free.');
GotoXY (63, 25); Write ('Lines: ');
count := 1;
Repeat
TextAttr := $15; { white on blue }
Update;
Repeat
CH := ReadKey;
If CH = #0 Then
Begin
CH := ReadKey;
Case CH Of
'H' : CH := #1; { up }
'P' : CH := #2; { down }
'Q' : CH := #3; { pg-up }
'I' : CH := #4; { pg-down }
'G' : CH := #5; { home }
'O' : CH := #6; { end }
#61 : CH := #7; {invoke lookfor F3}
#67 : CH := #8 {Screen Saver F10}
Else CH := #0; { discard }
End
End
Until CH In [#27, #1..#8 ] ;
Case CH Of
#1 : Dec ( count );
#2 : Inc ( count );
#3 : Inc ( count, 22 );
#4 : Dec ( count, 22 );
#5 : count := 1;
#6 : count := last;
#7 : LookFor (ParamStr (1) );
#8 : ScrS (ParamStr (1) );
End;
Until CH = #27;
End;
Procedure CleanUp;
Var I : Integer;
Begin For I := last Downto 1 Do
(* FreeMem ( FText [i], 1 + Length (FText [i]^) );*)
{This Causes RunTime Errors with the UMBHeap unit Added}
TextAttr := 0;
Curon;
ClrScr;
End;
Begin
If ParamCount <> 1 Then
Begin
ClrScr;
TextColor (15); WriteLn (' Cool View v1.0 Coded áy ScrewFace CopyRight
95-96' ); TextColor (8); WriteLn (' Usage : VIEWER
[Drive:[\Path\]Name.Ext'); Sound (600);
Delay (200);
Sound (500);
Delay (500);
NoSound;
Halt (0)
End;
Init (ParamStr (1) );
{ If Lines > 0 Then}
Begin
Display (ParamStr (1) );
CleanUp;
End;
End.
=-==-==-=-=-=-=-==-=-=-=-=-==-=UNIT-==-=-=-=-=-==-==-=-=-=-=-==-=-=-
Unit Swunit;
{$A-,B-,D-,E-,F-,G+,I-,L-,N-,O-,R-,S-,V-,X+}
{$M $800,0,6550}
Interface
Procedure StringFx (s: String; X, Y, ic, c1, c2, c3 : Byte; del : Word);
Procedure Rot;
Procedure Curon;
Procedure Curoff;
Implementation
Uses Crt, DOS;
Function keypress : Boolean; Assembler; Asm
mov AH, 0BH; Int 21h; And AL, 0feh;
End;
Procedure StringFx (s: String; X, Y, ic, c1, c2, c3 : Byte; del : Word);
Var
i : Integer;
StrPos : Byte;
CH : Char;
Begin
GotoXY (X, Y);
TextAttr := ic;
Write (s);
StrPos := 1;
i := 1;
While Not KeyPressed Do
Begin
Delay (del);
GotoXY (X + (StrPos - 1), Y);
TextAttr := ic; Write (s [StrPos] );
TextAttr := c1; Write (s [StrPos + 1] );
TextAttr := c2; Write (s [StrPos + 2] );
TextAttr := c3; Write (s [StrPos + 3] );
TextAttr := c2; Write (s [StrPos + 4] );
TextAttr := c1; Write (s [StrPos + 5] );
TextAttr := ic; Write (s [StrPos + 6] );
Inc (StrPos, i);
If StrPos + 6 = Ord (S [0] ) Then i := - 1;
If StrPos = 1 Then i := 1;
End;
{ ch := readkey; if ch = #0 Then ch := readkey;}
End;
Procedure Curoff;
Begin
Asm (* cursor off / Remove this if using the Code for A Door*)
MOV AH, 3
XOr BX, BX
Int 10H
Or CH, 20H
MOV AH, 1
Int 10H
End;
End;
{clrscr; (*Examples*)
StringFx(' úú Press Any Key úú ',(lo(windmax) div
2)-10,hi(windmax)+1,red,lightred,lightred,15,300);{clrscr;
StringFx(' úú Press Any Key úú ',(27),11,red,lightred,lightred,15,50);}
Procedure Curon;
Begin
Asm (* cursor on / Remove this if using the Code for A Door*)
MOV AH, 3
XOr BX, BX
Int 10H
And CH, 1FH
MOV AH, 1
Int 10H
End;
End;
Procedure Rot;
{Dont Remmber Who made this But I put in Here cause it Was Cool}
Const
gseg : Word = $a000;
dots = 459;
dist : Word = 250;
sintab : Array [0..255] Of Integer = (
0, 3, 6, 9, 13, 16, 19, 22, 25, 28, 31, 34, 37, 40, 43, 46, 49, 52, 55, 58,
60, 63, 66, 68, 71, 74, 76, 79, 81, 84, 86, 88, 91, 93, 95, 97, 99, 101, 103,
105, 106, 108, 110, 111, 113, 114, 116, 117, 118, 119, 121, 122, 122, 123,
124, 125, 126, 126, 127, 127, 127, 128, 128, 128, 128, 128, 128, 128, 127,
127, 127, 126, 126, 125, 124, 123, 122, 122, 121, 119, 118, 117, 116, 114,
113, 111, 110, 108, 106, 105, 103, 101, 99, 97, 95, 93,
91, 88, 86, 84, 81, 79, 76, 74, 71, 68, 66, 63, 60, 58, 55, 52, 49, 46, 43,
40, 37, 34, 31, 28, 25, 22, 19, 16, 13, 9, 6, 3, 0, - 3, - 6, - 9, - 13, -
16, - 19, - 22, - 25, - 28, - 31, - 34, - 37, - 40, - 43, - 46, - 49, - 52, -
55, - 58, - 60, - 63, - 66, - 68, - 71, - 74, - 76, - 79, - 81,
- 84, - 86, - 88, - 91, - 93, - 95, - 97, - 99, - 101, - 103, - 105, - 106,
- 108, - 110, - 111, - 113, - 114, - 116, - 117, - 118, - 119, - 121, - 122,
- 122, - 123, - 124, - 125, - 126, - 126, - 127, - 127, - 127, - 128, - 128,
- 128, - 128, - 128, - 128, - 128, - 127, - 127, - 127, - 126, - 126, - 125,
- 124, - 123, - 122, - 122, - 121, - 119, - 118, - 117, - 116,
- 114, - 113, - 111, - 110, - 108, - 106, - 105, - 103, - 101, - 99, - 97, -
95, - 93, - 91, - 88, - 86, - 84, - 81, - 79, - 76, - 74, - 71, - 68, - 66, -
63, - 60, - 58, - 55, - 52, - 49, - 46, - 43, - 40, - 37, - 34, - 31, - 28, -
25, - 22, - 19, - 16, - 13, - 9, - 6, - 3);Type
dotrec = Record X, Y, z : Integer; End;
dotpos = Array [0..dots] Of dotrec;
Var dot : dotpos;
{----------------------------------------------------------------------------}
Procedure setpal (col, r, g, b : Byte); Assembler; Asm
mov DX, 03c8h; mov AL, col; out DX, AL; Inc DX; mov AL, r
out DX, AL; mov AL, g; out DX, AL; mov AL, b; out DX, AL;
End;
Procedure setvideo (Mode : Word); Assembler; Asm
mov AX, Mode; Int 10h
End;
Function esc : Boolean; Begin
esc := port [$60] = 1;
End;
{----------------------------------------------------------------------------}
Procedure initi;
Var i : Word; X, z : Integer;
Begin
i := 0;
z := - 100;
While z < 100 Do Begin
X := - 100;
While X < 100 Do Begin
dot [i].X := X;
dot [i].Y := - 45;
dot [i].z := z;
Inc (i);
Inc (X, 10);
End;
Inc (z, 9);
End;
For i := 0 To 63 Do setpal (i, 0, i, i);
End;
{----------------------------------------------------------------------------}
Procedure rotation;
Const yst = 1;
Var
xp : Array [0..dots] Of Word;
yp : Array [0..dots] Of Byte;
X, z : Integer; n : Word; phiy : Byte;
Begin
Asm mov phiy, 0; mov ES, gseg; cli; End;
Repeat
Asm
mov DX, 03dah
@l1:
In AL, DX
Test AL, 8
jnz @l1
@l2:
In AL, DX
Test AL, 8
jz @l2
End;
setpal (0, 0, 0, 10);
For n := 0 To dots Do Begin
Asm
mov SI, n
mov AL, Byte Ptr yp [SI]
cmp AL, 200
jae @skip
ShL SI, 1
mov BX, Word Ptr xp [SI]
cmp BX, 320
jae @skip
ShL AX, 6
mov DI, AX
ShL AX, 2
add DI, AX
add DI, BX
XOr AL, AL
mov [ES: DI], AL
@skip:
End;
X := (sintab [ (phiy + 192) Mod 255] * dot [n].X
{^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^ ^ ^^^^^^^^
9 1 3 2 }
- sintab [phiy] * dot [n].z) Div 128;
{ ^ ^^^^^^^^^^^^ ^ ^^^^^^^^ ^^^^^^^
7 4 6 5 8 }
(*
asm
xor ah,ah { 1 }
mov al,phiy
add al,192
mov si,ax
mov ax,word ptr sintab[si]
mov si,n { 2 }
mov dx,word ptr dot[si].x
mul dx { 3 }
mov cx,ax
mov dx,word ptr dot[si].z { 5 }
mov al,phiy { 4 }
mov si,ax
mov ax,word ptr sintab[si]
mul dx { 6 }
sub cx,ax { 7 }
shr cx,7 { 8 }
mov x,cx { 9 }
end;
*)
z := (sintab [ (phiy + 192) Mod 255] * dot [n].z + sintab [phiy] * dot
[n].X) Div 128; xp [n] := 160 + (X * dist) Div (z - dist);
yp [n] := 100 + (dot [n].Y * dist) Div (z - dist);
{
asm
mov ax,x
mov dx,dist
mul dx
mov dx,z
sub dx,dist
div dx
add ax,160
(* can't assign ax to xp[n] !? *)
end;
}
Asm
mov SI, n
mov AL, Byte Ptr yp [SI]
cmp AL, 200
jae @skip
ShL SI, 1
mov BX, Word Ptr xp [SI]
cmp BX, 320
jae @skip
ShL AX, 6
mov DI, AX
ShL AX, 2
add DI, AX
add DI, BX
mov AX, z
ShR AX, 3
add AX, 30
mov [ES: DI], AL
@skip:
End;
End;
Asm Inc phiy End;
setpal (0, 0, 0, 0);
Until KeyPressed;
Asm sti End;
End;
{----------------------------------------------------------------------------}
Begin
setvideo ($13);
Initi;
rotation;
TextMode (LastMode);
End;
End.
[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]