[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
{Hi Dudes...
Dunno if you can do anything with this code; It sure is crappy!
Anywayzz, this kinda looks nice on my computer but I'm not sure
on how the timing will be on other systems... Might cause a
helluvalot of flicker...
Well, what can I say? Have Phun 8-)}
Program LooksLikeSomeTextModeEffectsToMe_YeahIGuessSo;
{$X+,E-,N-,I-,S-,R-,O-}
Type BigChar=Array[1..3,1..3] of Byte;
MoveRecord = Record
XPos,YPos : Integer;
XSpeed,YSpeed : Integer;
Counter : Word;
End;
Const BigFont : Array[1..40] of BigChar = (
((192,196,182),(195,196,191),(188,032,188)), {A}
((192,196,182),(195,196,191),(193,196,183)), {B}
((192,196,190),(187,032,032),(193,196,190)), {C}
((192,190,187),(187,032,187),(193,196,183)), {D}
((192,196,190),(195,190,032),(193,196,190)), {E}
((192,196,190),(195,190,032),(188,032,032)), {F}
((192,196,190),(187,194,182),(193,196,183)), {G}
((189,032,189),(195,196,191),(188,032,188)), {H}
((194,196,190),(032,187,032),(194,196,190)), {I}
((192,196,182),(195,196,191),(188,032,198)), {J}
((192,196,182),(195,196,191),(188,032,198)), {K}
((189,032,032),(187,032,032),(193,196,190)), {L}
((192,196,182),(187,189,187),(188,188,188)), {M}
((192,196,182),(187,032,187),(188,032,188)), {N}
((192,196,182),(187,032,187),(193,196,183)), {O}
((192,196,182),(187,032,187),(187,194,183)), {P}
((192,196,182),(195,196,191),(188,032,198)), {Q}
((192,196,182),(195,196,198),(188,032,197)), {R}
((192,196,190),(193,196,182),(194,196,183)), {S}
((194,196,190),(032,187,032),(032,188,032)), {T}
((189,032,189),(187,032,187),(193,196,183)), {U}
((189,032,187),(188,032,187),(194,196,183)), {V}
((189,189,189),(187,188,187),(193,196,183)), {W}
((189,032,189),(192,196,183),(188,032,187)), {X}
((189,032,189),(193,196,183),(032,188,032)), {Y}
((192,196,182),(195,196,191),(188,032,198)), {Z}
((032,032,032),(032,032,032),(185,185,185)), {...}
((032,187,032),(032,188,032),(032,185,032)), {!}
((192,196,182),(187,186,187),(193,196,183)), {0}
((194,182,032),(032,187,032),(194,196,190)), {1}
((194,196,182),(192,196,183),(193,196,190)), {2}
((194,196,182),(032,194,191),(194,196,183)), {3}
((189,032,189),(193,196,191),(032,032,188)), {4}
((192,196,190),(193,196,182),(194,196,183)), {5}
((192,196,190),(195,196,182),(193,196,183)), {6}
((194,196,182),(032,032,187),(032,032,188)), {7}
((192,196,182),(195,196,191),(193,196,183)), {8}
((192,196,182),(193,196,191),(194,196,183)), {9}
((032,032,032),(194,196,190),(032,032,032)), {-}
((032,032,032),(032,032,032),(032,032,032)));{ }
ScrWidth : Word = 160;
StartDat : Array[0..15] of Byte = (8,0,1,2,3,4,5,6,7,6,5,4,3,2,1,0);
BarRes = 270;
BarRad = 260 Div 2;
Mes : String = '';
ScrollMessage : String = 'Hi there possoms! howst hanging. How about some simple TextMode Scroller. ';
ScrollOfs : Byte = 9;
ScrollPos : Byte = 0;
CharOfs : Byte = 2;
Var BarCols : Array[0..399] of Byte;
Bars : Array[1..4] of Record
StartCol : Byte;
YPos : Integer;
End;
BarPos : Array[1..BarRes] of Integer;
MyPal : Array[0..767] of Byte;
MoveMes,MoveSplit : MoveRecord;
Procedure CharMap; Assembler;
Asm
db 0,0,0,0,0,0,192,240,248,252,252,60,60,60,60,60 {¿}
db 60,60,60,60,60,252,252,248,240,192,0,0,0,0,0,0 {Ù}
db 24,60,60,60, 60,60,60,60, 60,60,60,24, 0,0,0,0
db 0,0,0,0, 60,126,255,255, 255,255,126,60, 0,0,0,0
db 96,240,240,248, 248,120,124,60, 60,62,30,31, 31,15,15,6
db 60,60,60,60,60,60,60,60,60,60,60,60,60,60,60,60
db 60,60,60,60,60,60,60,60,60,60,60, 24, 0,0,0,0
db 0,0,0,0, 24,60,60,60,60,60,60,60,60,60,60,60
db 0,0,0,0,0,0,254,255,255,254,0,0,0,0,0,0 {->}
db 60,60,60,60,60,124,252,252,252,252,124,60,60,60,60,60
db 0,0,0,0,0,0,3,15,31,63,62,62,60,60,60,60 {Ú}
db 60,60,60,60,62,62,63,31,15,3,0,0,0,0,0,0 {À}
db 0,0,0,0,0,0,127,255,255,127,0,0,0,0,0,0 {<-}
db 60,60,60,60,60,62,63,63, 63,63,62,60, 60,60,60,60 {Ã}
db 0,0,0,0,0,0,255,255,255,255,0,0,0,0,0,0 {Ä}
db 240,120,120,120,120,120,60,60, 60,60,60,24, 0,0,0,0 {\}
db 60,60,60,60,60,252,252,248,240,224,224,240,240,240,240,240
End;
Procedure SetCharset; Assembler;
Asm
Push Bp
mov ax,cs { Set character set for logo }
mov es,ax
mov bp,cs:offset charmap
mov ax,1100h
mov bx,1000h
mov cx,17
mov dx,182
int 10h
Pop Bp
End;
Procedure Standard_Palette; Assembler; { DP ][ Ext. Compatible }
Asm
db 0,0,0,0,0,42,0,42,0,0,42,42,42,0,0,42,0,42,42,21,0,42,42
db 42,21,21,21,21,21,63,21,63,21,21,63,63,63,21,21,63,21,63,63,63,21,63
db 63,63,59,59,59,55,55,55,52,52,52,48,48,48,45,45,45,42,42,42,38,38,38
db 35,35,35,31,31,31,28,28,28,25,25,25,21,21,21,18,18,18,14,14,14,11,11
db 11,8,8,8,63,0,0,59,0,0,56,0,0,53,0,0,50,0,0,47,0,0,44
db 0,0,41,0,0,38,0,0,34,0,0,31,0,0,28,0,0,25,0,0,22,0,0
db 19,0,0,16,0,0,63,54,54,63,46,46,63,39,39,63,31,31,63,23,23,63,16
db 16,63,8,8,63,0,0,63,42,23,63,38,16,63,34,8,63,30,0,57,27,0,51
db 24,0,45,21,0,39,19,0,63,63,54,63,63,46,63,63,39,63,63,31,63,62,23
db 63,61,16,63,61,8,63,61,0,57,54,0,51,49,0,45,43,0,39,39,0,33,33
db 0,28,27,0,22,21,0,16,16,0,52,63,23,49,63,16,45,63,8,40,63,0,36
db 57,0,32,51,0,29,45,0,24,39,0,54,63,54,47,63,46,39,63,39,32,63,31
db 24,63,23,16,63,16,8,63,8,0,63,0,0,63,0,0,59,0,0,56,0,0,53
db 0,1,50,0,1,47,0,1,44,0,1,41,0,1,38,0,1,34,0,1,31,0,1
db 28,0,1,25,0,1,22,0,1,19,0,1,16,0,54,63,63,46,63,63,39,63,63
db 31,63,62,23,63,63,16,63,63,8,63,63,0,63,63,0,57,57,0,51,51,0,45
db 45,0,39,39,0,33,33,0,28,28,0,22,22,0,16,16,23,47,63,16,44,63,8
db 42,63,0,39,63,0,35,57,0,31,51,0,27,45,0,23,39,54,54,63,46,47,63
db 39,39,63,31,32,63,23,24,63,16,16,63,8,9,63,0,1,63,0,0,63,0,0
db 59,0,0,56,0,0,53,0,0,50,0,0,47,0,0,44,0,0,41,0,0,38,0
db 0,34,0,0,31,0,0,28,0,0,25,0,0,22,0,0,19,0,0,16,60,54,63
db 57,46,63,54,39,63,52,31,63,50,23,63,47,16,63,45,8,63,42,0,63,38,0
db 57,32,0,51,29,0,45,24,0,39,20,0,33,17,0,28,13,0,22,10,0,16,63
db 54,63,63,46,63,63,39,63,63,31,63,63,23,63,63,16,63,63,8,63,63,0,63
db 56,0,57,50,0,51,45,0,45,39,0,39,33,0,33,27,0,28,22,0,22,16,0
db 16,63,58,55,63,56,52,63,54,49,63,53,47,63,51,44,63,49,41,63,47,39,63
db 46,36,63,44,32,63,41,28,63,39,24,60,37,23,58,35,22,55,34,21,52,32,20
db 50,31,19,47,30,18,45,28,17,42,26,16,40,25,15,39,24,14,36,23,13,34,22
db 12,32,20,11,29,19,10,27,18,9,23,16,8,21,15,7,18,14,6,16,12,6,14
db 11,5,10,8,3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
db 0,0,0,0,0,0,49,10,10,49,19,10,49,29,10,49,39,10,49,49,10,39,49
db 10,29,49,10,19,49,10,10,49,12,10,49,23,10,49,34,10,49,45,10,42,49,10
db 31,49,10,20,49,11,10,49,22,10,49,33,10,49,44,10,49,49,10,43,49,10,32
db 49,10,21,49,10,10,63,63,63
End;
Function KeyPressed : Boolean; Assembler;
Asm
Mov Ah,0Bh
Int 21h
End;
Procedure WriteBigMessage(X,Y,Color:Byte; Message:String);
Var B,D : Byte;
ScrOfs : Word;
Const TransTab : Array[0..255] of Byte =
(32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32, {15}
32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32, {31}
40,28,32,32,32,32,32,32,32,32,32,32,32,39,27,32, {47}
29,30,31,32,33,34,35,36,37,38,32,32,32,32,32,32, {63}
32, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, {79}
16,17,18,19,20,21,22,23,24,25,26,32,32,32,32,32, {95}
32, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, {111}
16,17,18,19,20,21,22,23,24,25,26,32,32,32,32,32, {127}
32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,
32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,
32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,
32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,
32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,
32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,
32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,
32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32);
Begin
Mes:=Message;
D:=Length(Mes);
If D=0 then Exit;
ScrOfs:=(Y-1)*ScrWidth+2*X+2;
Asm
Mov Ax,$B800 { Set starting address on screen }
Mov Es,Ax
Mov Di,ScrOfs
Mov B,1 { Start with first character ;-) }
@StringLoop:
Xor Bh,Bh
Mov Bl,B
Mov Al,Ds:[Offset Mes+Bx] { Get Next Character from String }
Mov Bx,Offset TransTab
XLat { And translate into real value }
Dec Al
Mov Bl,9
Mul Bl
Mov Si,Offset BigFont { Character offset in Font-Table }
Add Si,Ax
Mov Ah,Color
Mov Dx,3
@FontColumn: { Loop three Rows... }
Mov Cx,3
@FontRow: { and three columns }
LodsB
StosW
Loop @FontRow
Add Di,ScrWidth
Sub Di,6
Dec Dx
Jnz @FontColumn
Mov Ax,3 { prepare screen address for next character }
Mul ScrWidth
Sub Di,Ax
Add Di,8
Inc B
Mov Al,D
Cmp B,Al
Jng @StringLoop
End;
End;
Procedure WriteCenteredBig(Y,Color:Byte; Message:String);
Begin
WriteBigMessage(((ScrWidth Div 4)+2)-(Length(Message)*2),Y,Color,Message);
End;
Procedure MakePal;
Var A:Word;
Begin
For A:=0 to 255 do
Begin
Mypal[A]:=Mem[Seg(Standard_Palette):Ofs(Standard_Palette)+A*3];
Mypal[A+256]:=Mem[Seg(Standard_Palette):Ofs(Standard_Palette)+A*3+1];
Mypal[A+512]:=Mem[Seg(Standard_Palette):Ofs(Standard_Palette)+A*3+2];
End;
End;
Procedure SetupBars;
Var V : Integer;
Begin
For V:=1 To BarRes Do
BarPos[V]:=Round(BarRad*Sin((2*Pi/BarRes)*V))+BarRad+1;
For V:=1 to 4 do
With Bars[V] do
Begin
StartCol:=V*16;
if v=3 then startcol:=96;
if v=4 then startcol:=144;
if v=5 then startcol:=160;
YPos:=14*V;
End;
For V:=304 to 319 do Barcols[V]:=(15-(V mod 16))+160;
For V:=320 to 335 do Barcols[V]:=V mod 16+160;
End;
Procedure UpdateBars;
Var V,U,Y : Integer;
Begin
For V:=1 To 4 do
For U:=0 to 31 do BarCols[barpos[Bars[V].YPos]+U]:=0;
For V:=1 To 4 do
Begin
Inc(Bars[V].YPos);
If Bars[V].YPos>BarRes then Bars[V].YPos:=1;
Y:=BarPos[Bars[V].YPos];
For U:=0 to 15 do BarCols[Y+U]:=Bars[V].StartCol+15-U;
For U:=16 to 31 do BarCols[Y+U]:=Bars[V].StartCol+U-16;
End;
End;
Procedure ColorBars; Assembler;
Asm
MOV DX,$03DA
In AL,DX
MOV DX,$03C0 { assume color nr 0 = default Text background.. }
MOV AL,$20+0 { set color nr 0 .. }
OUT DX,AL
MOV AL,0 { .. to DAC color 0 }
OUT DX,AL
Xor SI,SI
CLI
MOV DX,$03DA
MOV AH,8
@Wau: in AL,DX
TEST AL,AH
JNZ @Wau { wait Until out of retrace }
@Wai: in AL,DX
TEST AL,AH
JZ @Wai { wait Until inside retrace }
@Doline:
STI
Mov Bl,[Offset BarCols+Si]
Mov Di,Offset MyPal
Add Di,Bx
MOV DX,$03C8 { point to DAC[0] }
MOV AL,0
OUT DX,AL
CLI
MOV DX,$03DA
@Whu: in AL,DX
RCR AL,1
JC @Whu { wait Until out of horizontal retrace }
@Whi: in AL,DX
RCR AL,1
JNC @Whi { wait Until inside retrace }
Inc Si { line counter }
{ prepare For color effect }
MOV DX,$03C9
Mov Al,[Di]
OUT DX,Al { Dynamic Red }
Mov Al,[Di+256]
OUT DX,AL { Dynamic Green }
mov Al,[Di+512]
OUT DX,AL { Dynamic Blue }
CMP SI,296 { Paint just about 3/4 screen }
JBE @doline
STI
End;
PROCEDURE Split(Row:Integer);
BEGIN
ASM
mov dx,$3d4
mov ax,row
mov bh,ah
mov bl,ah
and bx,201h
mov cl,4
shl bx,cl
mov ah,al
mov al,18h
out dx,ax
mov al,7
cli
out dx,al
inc dx
in al,dx
sti
dec dx
mov ah,al
and ah,0efh
or ah,bl
mov al,7
out dx,ax
mov al,9
cli
out dx,al
inc dx
in al,dx
sti
dec dx
mov ah,al
and ah,0bfh
shl bh,1
shl bh,1
or ah,bh
mov al,9
out dx,ax
END;
END;
Procedure FastWrite(Col,Row,Attrib:Byte; Str:String);
Var MemPos : Word;
A : Byte;
Begin
MemPos:=(Col*2)+(Row*ScrWidth)-ScrWidth-2;
A:=Length(Str);
For A:=1 to Length(Str) do
Begin
MemW[$B800:MemPos]:=Ord(Str[A])+Attrib*256;
MemPos:=MemPos+2;
End;
End;
Procedure CenterWrite(Y,Color:Byte;Mes:String);
Begin
FastWrite(41-((Length(Mes)-1) Div 2),Y,Color,Mes);
End;
Procedure CursorOff; Assembler;
Asm
Mov Ax,0100h
Mov Cx,2000h
Int 10h
End;
Procedure CursorOn; Assembler;
Asm
Mov Ax,0100h
Mov Cx,0607h
Int 10h
End;
Procedure ScrollText(Nr:Word); Assembler;
Asm
mov ax,nr
mov cx,$40
mov es,cx
mov cl,es:[$85]
div cl
mov cx,ax
mov dx,es:[$63]
push dx
mov al,$13
cli
out dx,al
inc dx
in al,dx
sti
mul cl
shl ax,1
mov es:[$4e],ax
pop dx
mov cl,al
mov al,$c
out dx,ax
mov al,$d
mov ah,cl
out dx,ax
mov ah,ch
mov al,8
out dx,ax
End;
Function ReadKey : Char; Assembler;
Asm
Mov Ah,07h
Int 21h
End;
Procedure SetHorizOfs(Count:Byte);
Var I : Byte;
Begin
I:=Port[$3DA];
Port[$3C0]:=$33;
Port[$3C0]:=StartDat[Count Mod 16];
End;
Procedure Sync; Assembler;
Asm
Mov Dx,3DAh
@LoopIt:
In Al,Dx
Test Al,8
Jz @LoopIt
End;
Procedure DoubleWidth; Assembler;
Asm
Mov Dx,3D4h
Mov Ax,5013h
Out Dx,Ax
Mov ScrWidth,320
End;
Procedure SetPELReset; Assembler;
Asm
Mov Dx,3DAh
In Al,Dx
Mov Dx,3C0h
Mov Al,30h
Out Dx,Al
Mov Al,2Ch
Out Dx,Al
End;
Procedure SetView(X,Y:Word);
Var PelPos:Byte;
Begin
PelPos:=StartDat[X Mod 9];
X:=(X Div 9)+(Y Div 16)*160;
Asm
Mov Dx,3D4h { Set Screen offset in bytes:}
Mov Bx,X
Mov Ah,Bh
Mov Al,0Ch
Out Dx,Ax
Mov Ah,Bl
Inc Al
Out Dx,Ax
Mov Al,8 { Set Y-Offset within Character-Row: }
Mov Bx,Y
And Bl,15
Mov Ah,Bl
Out Dx,Ax
Mov Dx,3C0h { Set X-Offset within Character-Column: }
Mov Al,33h
Out Dx,Al
Mov Al,PelPos
Out Dx,Al
End;
End;
Procedure UpDateScroller;
Begin
If ScrollOfs=9 then
Begin
ScrollOfs:=0;
Move(Mem[$B800:14*320+2],Mem[$B800:14*320],3*320-2);
Inc(CharOfs);
If CharOfs=4 then
Begin
Inc(ScrollPos);
WriteBigMessage(84-CharOfs,15,14,ScrollMessage[ScrollPos]);
If ScrollPos=Length(ScrollMessage) Then ScrollPos:=0;
CharOfs:=0;
End;
End
else
Inc(ScrollOfs,9);
SetHorizOfs(ScrollOfs);
End;
Begin
CursorOff;
FillChar(Mem[$B800:0000],4000,0);
With MoveMes do
Begin
YPos:=110;
YSpeed:=2;
XPos:=40*8;
XSpeed:=3;
Counter:=0;
End;
With MoveSplit Do
Begin
YPos:=295;
YSpeed:=2;
End;
DoubleWidth;
SetPelReset;
ScrollText(MoveMes.YPos);
Split(MoveSplit.YPos);
Setupbars;
MakePal;
SetCharSet;
Sync;
CenterWrite(1,14,#194'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'#190);
WriteBigMessage(1,2,4,'GAME - Gotta Get it!');
CenterWrite(5,14,#194'ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'#190);
Repeat
With MoveMes do
Begin
If (YPos>80) and (YPos<200) then
Inc(YPos,YSpeed)
else
Begin
YSpeed:=-YSpeed;
YPos:=YPos+YSpeed;
End;
Counter:=1-Counter;
If Odd(Counter) then
Begin
If (XPos<40*8) or (XPos>40*8+150) then XSpeed:=-XSpeed;
Inc(XPos,XSpeed);
End;
End;
With MoveSplit do
Begin
If (YPos>290) and (YPos<325) then
Inc(YPos,YSpeed)
else
Begin
YSpeed:=-YSpeed;
YPos:=YPos+YSpeed;
End;
End;
UpdateBars;
ScrollText(MoveMes.YPos);
UpDateScroller;
Split(MoveSplit.YPos);
ColorBars;
Until KeyPressed;
While KeyPressed do Readkey;
Split(400);
SetView(0,0);
ScrollText(0);
Asm
Mov Ax,3
Int 10h
End;
FastWrite(1,1,15,'Bye from World of Wonders!');
Writeln;
CursorOn;
End.
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]