{$G+}
Unit Qwik;
INTERFACE
const
smal = $0707; { For Cursor manipulate }
norm = $0607;
half = $0307;
Bar = $000D;
Off = $2607;
on = $0506;
MaxVensters = 5; { playraam }
type
Charset = Set of #0..#255; { For Qinput procedure }
DAC_Trio=Record
Red,Green,Blue:Byte; { For fade in/out }
End;
VensterPtr = ^VENSTERTYPE;
VENSTERTYPE = record
Data : array[1..4000] of Char;
XPos : Byte;
YPos : Byte;
VenX1 : Byte;
VenY1 : Byte;
VenX2 : Byte;
VenY2 : Byte;
end;
ScreenArray = ARRAY[1..25 * 80] OF WORD; { dump asci screen }
ScreenPtr = ^ScreenArray;
DacType = Array[1..256,1..3] of Byte;
ByteArray = Array[0..15] of Byte; { New CharacterSets }
CharArray = Array[1..101] of Record
CN : Byte;
CD : ByteArray;
end;
Const
newChars : CharArray =
{ kader }
((CN:218;CD:(0,0,7,15,28,56,48,48,48,48,48,48,48,48,48,48)), {Ú}
(CN:194;CD:(0,0,255,255,0,0,0,0,0,0,0,0,0,0,0,0)), {Â}
(CN:191;CD:(0,0,224,240,56,28,12,12,12,12,12,12,12,12,12,12)), {¿}
(CN:195;CD:(48,48,48,48,48,48,48,48,48,48,48,48,48,48,48,48)), {Ã}
(CN:180;CD:(12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12)), {´}
(CN:192;CD:(48,48,48,48,48,48,48,48,48,48,56,28,15,7,0,0)), {À}
(CN:193;CD:(0,0,0,0,0,0,0,0,0,0,0,0,255,255,0,0)), {Á}
(CN:217;CD:(12,12,12,12,12,12,12,12,12,12,28,56,240,224,0,0)), {Ù}
{ name softdesign ÈÉÊËÌÍÎÏÐÑÒ }
(CN:200;CD:(127,128,128,159,144,144,144,144,158,144,144,144,
144,128,128,127)), {È}
(CN:201;CD:(255,0,0,19,18,18,18,18,19,18,18,18,18,0,0,255)), {É}
(CN:202;CD:(255,0,0,195,36,36,36,36,195,128,128,68,35,0,0,255)), {Ê}
(CN:203;CD:(255,0,0,31,130,2,2,2,2,130,130,130,2,0,0,255)), {Ë}
(CN:204;CD:(255,0,0,129,2,2,2,2,2,2,2,2,1,0,0,255)), {Ì}
(CN:205;CD:(255,0,0,199,36,36,36,36,39,36,36,36,196,0,0,255)), {Í}
(CN:206;CD:(255,0,0,132,68,68,68,68,132,4,4,4,4,0,0,255)), {Î}
(CN:207;CD:(255,0,0,66,98,82,74,70,66,66,66,66,66,0,0,255)), {Ï}
(CN:208;CD:(255,0,0,33,34,34,34,34,34,34,34,34,33,0,0,255)), {Ð}
(CN:209;CD:(255,0,0,196,38,37,36,36,36,36,36,36,196,0,0,255)), {Ñ}
(CN:210;CD:(252,2,2,34,34,34,162,98,34,34,34,34,34,2,2,252)), {Ò}
{ diversen }
(CN:220;CD:(0,0,255,255,255,255,255,255,255,255,255,255,255,255,
255,255)), {Ü}
(CN:221;CD:(252,252,252,252,252,252,252,252,252,252,252,252,
252,252,252,252)), {Ý}
(CN:222;CD:(31,31,31,31,31,31,31,31,31,31,31,31,31,31,31,31)), {Þ}
(CN:223;CD:(255,255,255,255,255,255,255,255,255,255,255,255,255,
255,0,0)), {ß}
{ ASCII backgronds }
(CN:225;CD:(148,132,72,48,0,193,34,20,148,132,72,48,0,193,34,20)), {á}
(CN:226;CD:(32,64,143,16,32,64,143,16,32,64,143,16,32,64,143,16)), {â}
(CN:227;CD:(129,66,36,16,8,4,34,25,152,66,32,16,8,36,66,129)), {ã}
(CN:228;CD:(62,65,65,65,65,65,62,128,62,65,65,65,65,65,62,128)), {ä}
(CN:229;CD:(0,0,0,0,16,32,64,255,64,32,16,0,0,0,0,0)), { pijl å}
(CN:230;CD:(0,0,0,0,0,1,7,252,7,1,0,0,0,0,0,0)), { pijl æ}
(CN:249;CD:(0,0,0,0,0,4,6,255,255,6,4,0,0,0,0,0)), { pijl printmenu ù}
{ numbers 0..9 }
(CN:48;CD:(0,60,66,66,66,66,66,66,66,66,66,60,0,0,0,0)), {0}
(CN:49;CD:(0,8,24,56,8,8,8,8,8,8,8,62,0,0,0,0)), {1}
(CN:50;CD:(0,60,66,2,2,4,8,16,32,64,64,126,0,0,0,0)), {2}
(CN:51;CD:(0,60,66,2,2,4,24,4,2,2,66,60,0,0,0,0)), {3}
(CN:52;CD:(0,2,6,10,18,34,66,126,2,2,2,2,0,0,0,0)), {4}
(CN:53;CD:(0,126,64,64,64,64,124,2,2,2,66,60,0,0,0,0)), {5}
(CN:54;CD:(0,60,66,64,64,64,124,66,66,66,66,60,0,0,0,0)), {6}
(CN:55;CD:(0,126,2,2,4,4,8,8,16,16,32,32,0,0,0,0)), {7}
(CN:56;CD:(0,60,66,66,66,66,60,66,66,66,66,60,0,0,0,0)), {8}
(CN:57;CD:(0,60,66,66,66,66,62,2,2,2,66,60,0,0,0,0)), {9}
{ characters A..Z }
(CN:65;CD:(0,60,66,66,66,66,126,66,66,66,66,66,0,0,0,0)), {A}
(CN:66;CD:(0,124,66,66,66,66,124,66,66,66,66,124,0,0,0,0)), {B}
(CN:67;CD:(0,28,34,64,64,64,64,64,64,64,34,28,0,0,0,0)), {C}
(CN:68;CD:(0,120,68,66,66,66,66,66,66,66,68,120,0,0,0,0)), {D}
(CN:69;CD:(0,126,64,64,64,64,120,64,64,64,64,126,0,0,0,0)), {E}
(CN:70;CD:(0,126,64,64,64,64,124,64,64,64,64,64,0,0,0,0)), {F}
(CN:71;CD:(0,60,66,64,64,64,78,66,66,66,66,60,0,0,0,0)), {G}
(CN:72;CD:(0,66,66,66,66,66,126,66,66,66,66,66,0,0,0,0)), {H}
(CN:73;CD:(0,28,8,8,8,8,8,8,8,8,8,28,0,0,0,0)), {I}
(CN:74;CD:(0,14,4,4,4,4,4,4,4,4,68,56,0,0,0,0)), {J}
(CN:75;CD:(0,66,68,72,80,96,96,96,80,72,68,66,0,0,0,0)), {K}
(CN:76;CD:(0,64,64,64,64,64,64,64,64,64,64,126,0,0,0,0)), {L}
(CN:77;CD:(0,65,65,99,85,73,65,65,65,65,65,65,0,0,0,0)), {M}
(CN:78;CD:(0,66,66,98,82,74,70,66,66,66,66,66,0,0,0,0)), {N}
(CN:79;CD:(0,24,36,66,66,66,66,66,66,66,36,24,0,0,0,0)), {O}
(CN:80;CD:(0,124,66,66,66,66,124,64,64,64,64,64,0,0,0,0)), {P}
(CN:81;CD:(0,24,36,66,66,66,66,82,74,74,36,26,0,0,0,0)), {Q}
(CN:82;CD:(0,124,66,66,66,66,124,96,80,72,68,66,0,0,0,0)), {R}
(CN:83;CD:(0,60,66,64,64,64,60,2,2,2,66,60,0,0,0,0)), {S}
(CN:84;CD:(0,127,8,8,8,8,8,8,8,8,8,8,0,0,0,0)), {T}
(CN:85;CD:(0,66,66,66,66,66,66,66,66,66,66,60,0,0,0,0)), {U}
(CN:86;CD:(0,66,66,66,66,66,66,66,36,36,36,24,0,0,0,0)), {V}
(CN:87;CD:(0,65,65,65,65,65,73,73,42,54,34,34,0,0,0,0)), {W}
(CN:88;CD:(0,66,66,66,36,36,24,24,36,36,66,66,0,0,0,0)), {X}
(CN:89;CD:(0,65,65,65,65,34,34,28,8,8,8,8,0,0,0,0)), {Y}
(CN:90;CD:(0,127,2,4,4,8,8,16,16,32,32,127,0,0,0,0)), {Z}
(CN:196;CD:(0,0,0,0,0,0,0,204,51,0,0,0,0,0,0,0)), {Ä}
(CN:179;CD:(16,16,8,8,16,16,8,8,16,16,8,8,16,16,8,8)), {³}
(CN:58;CD:(0,0,0,0,0,12,12,0,0,0,12,12,0,0,0,0)), {:}
(CN:45;CD:(0,0,0,0,0,0,0,126,0,0,0,0,0,0,0,0)), {-}
(CN:40;CD:(0,2,4,4,8,8,8,8,8,4,4,2,0,0,0,0)), {(}
(CN:41;CD:(0,32,16,16,8,8,8,8,8,16,16,32,0,0,0,0)), {)}
{ balk voor B.V. Vloeiende BackupStatusBar }
(CN:231;CD:(145,196,145,196,145,196,145,196,145,196,145,196,145,
196,145,196)), {ç}
(CN:232;CD:(209,196,209,196,209,196,209,196,209,196,209,196,209,
196,209,196)), {è}
(CN:233;CD:(241,228,241,228,241,228,241,228,241,228,241,228,241,
228,241,228)), {é}
(CN:234;CD:(241,244,241,244,241,244,241,244,241,244,241,244,241,
244,241,244)), {ê}
(CN:235;CD:(249,252,249,252,249,252,249,252,249,252,249,252,249,
252,249,252)), {ë}
(CN:236;CD:(253,252,253,252,253,252,253,252,253,252,253,252,253,
252,253,252)), {ì}
(CN:237;CD:(255,254,255,254,255,254,255,254,255,254,255,254,255,
254,255,254)), {í}
(CN:238;CD:(255,255,255,255,255,255,255,255,255,255,255,255,255,
255,255,255)), {î}
{ JOS DICKMANN SOFTWARE (c) 1997 }
{J} (CN : 210;CD :
($1E,$1E,$0C,$0C,$0C,$0C,$0C,$0C,$CC,$CC,$CC,$CC,$78,$78,$00,$00)),
{O} (CN : 190;CD :
($38,$38,$6C,$6C,$C6,$C6,$C6,$C6,$C6,$C6,$6C,$6C,$38,$38,$00,$00)),
{S} (CN : 141;CD :
($7C,$7C,$C6,$C6,$E0,$E0,$78,$78,$0E,$0E,$C6,$C6,$7C,$7C,$00,$00)),
{D} (CN : 159;CD :
($F8,$F8,$6C,$6C,$66,$66,$66,$66,$66,$66,$6C,$6C,$F8,$F8,$00,$00)),
{I} (CN : 242;CD :
($78,$78,$30,$30,$30,$30,$30,$30,$30,$30,$30,$30,$78,$78,$00,$00)),
{C} (CN : 226;CD :
($3C,$3C,$66,$66,$C0,$C0,$C0,$C0,$C0,$C0,$66,$66,$3C,$3C,$00,$00)),
{K} (CN : 171;CD :
($E6,$E6,$66,$66,$6C,$6C,$78,$78,$6C,$6C,$66,$66,$E6,$E6,$00,$00)),
{M} (CN : 156;CD :
($C6,$C6,$EE,$EE,$FE,$FE,$FE,$FE,$D6,$D6,$C6,$C6,$C6,$C6,$00,$00)),
{A} (CN : 179;CD :
($30,$30,$78,$78,$CC,$CC,$CC,$CC,$FC,$FC,$CC,$CC,$CC,$CC,$00,$00)),
{N} (CN : 250;CD :
($C6,$C6,$E6,$E6,$F6,$F6,$DE,$DE,$CE,$CE,$C6,$C6,$C6,$C6,$00,$00)),
{F} (CN : 161;CD :
($FE,$FE,$62,$62,$68,$68,$78,$78,$68,$68,$60,$60,$F0,$F0,$00,$00)),
{T} (CN : 254;CD :
($FC,$FC,$B4,$B4,$30,$30,$30,$30,$30,$30,$30,$30,$78,$78,$00,$00)),
{W} (CN : 130;CD :
($C6,$C6,$C6,$C6,$C6,$C6,$C6,$C6,$D6,$D6,$FE,$FE,$6C,$6C,$00,$00)),
{R} (CN : 172;CD :
($FC,$FC,$66,$66,$66,$66,$7C,$7C,$6C,$6C,$66,$66,$E6,$E6,$00,$00)),
{E} (CN : 253;CD :
($FE,$FE,$62,$62,$68,$68,$78,$78,$68,$68,$62,$62,$FE,$FE,$00,$00)),
{c} (CN : 199;CD :
($00,$00,$00,$00,$78,$78,$CC,$CC,$C0,$C0,$CC,$CC,$78,$78,$00,$00)),
{(} (CN : 247;CD :
($18,$18,$30,$30,$60,$60,$60,$60,$60,$60,$30,$30,$18,$18,$00,$00)),
{)} (CN : 233;CD :
($60,$60,$30,$30,$18,$18,$18,$18,$18,$18,$30,$30,$60,$60,$00,$00)),
{1} (CN : 248;CD :
($30,$30,$70,$70,$30,$30,$30,$30,$30,$30,$30,$30,$FC,$FC,$00,$00)),
{9} (CN : 223;CD :
($78,$78,$CC,$CC,$CC,$CC,$7C,$7C,$0C,$0C,$18,$18,$70,$70,$00,$00)),
{5} (CN : 191;CD :
($FC,$FC,$C0,$C0,$F8,$F8,$0C,$0C,$0C,$0C,$CC,$CC,$78,$78,$00,$00)));
{ QWIK.TPU }
Procedure Qread_char; { read the standard characters ASCII set }
Procedure Qreset_char; { reset the old character set }
procedure Qfont0; { standard ASCII font }
procedure Qfont1; { new font for ASCII characters }
procedure Qfont_jos;
{ Qfont_jos is a personal(private) procedure |
| writeln('Ò¾ Ÿòâ«œ³úú ¾¡þ‚³¬ý ÷Çé øßß¿'); |
| title =('JOS DICKMANN SOFTWARE (c) 1997') }
Function Qinput(X,Y: Byte;StartStr,BackG,PassChar: String;MaxLen,StartPos:
Integer;AcceptSet: CharSet;Ins: Boolean;var InputStatus: Byte):string;
{ X,Y Where on screen to put the input. |
| StartStr Default input string. |
| BackG Background Character, eg ' ' or '°' etc. |
| PassChar If defined this character will be |
| displyed instead of the input stream |
| MaxLen MaxLen of Input. |
| StartPos Where in input string to place cursor, |
| -1 = End of StartStr |
| AcceptSet : Which characters should be accepted |
| as input,often [#32..#255] |
| if you include #8 in mask, you cannot use delete |
| Ins : Begin in INSERT or OVERWRITE mode Boolean |
| InputStatus exit from the input routine |
| 13 = Input terminated with Enter. |
| 27 = Input terminated with ESC. |
| 72 = User pressed UpArrow |
| 80 = User pressed DownArrow |
| 73 = User pressed Page Up |
| 81 = User pressed Page Down etc.... }
function Qstring(x,y,color,maxlen :byte;AcceptSet: CharSet):string;
{ x,y Where on screen to put the input. |
| MaxLen MaxLen of Input. |
| AcceptSet = Which characters should be |
| accepted as input, often [#32..#255] }
{ THE FOLLOW PROCEDURES ONLY USED IN WINDOW 0,0,80,25 }
Procedure Qwrite(x, y: byte; s: string; f, b: byte);
Procedure Qhor_write(x,y,aantal,teken,kleur :byte);
{ Qhor_write(20,2,10,176,3) = °°°°°°°°°° }
Procedure Qver_write(x,y,aantal,teken,kleur :byte);
{ vertical asci rules }
{ USE IN PROCEDURE QWINDOW }
procedure Qtext(x,y :byte;str :string;kleur,achtergrondkleur : Byte);
Procedure Qhor(x,y,aantal,teken,kleur :byte);
Procedure Qver(x,y,aantal,teken,kleur :byte);
Procedure QCursor(Ctype: Word);
{ smal = $0707; | | norm = $0607; | | half = $0307; |
| Bar = $000D; | | Off = $2607; | | on = $0506; }
Procedure Qtime(x,y,kleur,achtergrondkleur :byte);
Procedure Qdate(x,y,kleur,achtergrondkleur :byte);
{ kleur = color / achtergrondkleur = background color }
Function Qday_of_week(Month,Day,Year :word):byte;
{ read the day of the week 0..6 }
Function NumbofDaysInMth(y,m : Word): Byte;
{ read the days in a month / januari = 31 etc... }
Procedure Qscreen_off;
Procedure Qscreen_on;
Procedure Qdelay(ms : Word); { ms = milliseconds }
Procedure Qfill_screen(char,color :byte); { Fill screen 80x25 characters }
Procedure Qborder(kleur: byte); { fills the border of the screen }
Procedure Qsave_screen(filename :string);
Procedure Qload_screen(filename :string); { I don't know of this works }
{ var Page : ARRAY[0..2] OF PageType; |
| Counter : integer;key :char; |
| |
| begin |
| Page[0] := Monitor; |
| LoadScreen(Page[1],paramstr(1)); |
| LoadScreen(Page[2],paramstr(2)); |
| repeat |
| while KeyPressed DO Key := ReadKey; |
| IF Counter = 1 THEN Counter := 2 |
| else Counter := 1; |
| PageFlip(Page[Counter],AllRand); |
| until Key = #27; |
| PageFlip(Page[0],AllRand); |
| end. }
Procedure QScroll(x,y :byte;s:string;back,textcolor,highlight,dlay,
waitkey:word);
{ x,y = screen location (1..80, 1..25) |
| s = message to be displayed (length = 2..75) |
| back = background color (0..7) |
| textcolor = text color (0..15) |
| highlight = highlight color (0..15) |
| dlay = time delay (milliseconds) (0..) |
| waitkey = 0 - cycle once only |
| 1 - continue cycle until a key is hit }
Procedure QFade_Out; { also for graphics screens }
Procedure QFade_in;
Procedure Qfadeout(Speed : Integer); { for asci screens }
Procedure Qfadein(Speed : Integer); { for asci screens }
Function QGetChar(X,Y:Byte):Char; { get the character on X,Y }
procedure Qdel_file(filename :string); { delete a file }
function Qexist_file(FileName : string) : boolean;
function Qexist_dir(dir:string):boolean;
procedure Qget_file_attr(fn:string;var Attr:word);
procedure Qset_file_attr(fn :string;Attr:word);
procedure Qget_file_size(FName :string;var Fsize :longint;var Error :word);
procedure QCopy_file(file_of,file_to :string);
procedure Qclear_buffer; { clear the keybord }
function Qread_key :word;
procedure Qsound(freq,delay :integer);
procedure Qinfo(regel :string); { put info-text on rule 23 }
Function Qerror(ErrorCode :integer):string;
{ 0: No Error'; |
| 2: File Not Found'; |
| 3: Path Not Found'; |
| 4: Too Many Open Files'; |
| 5: File Access Denied'; |
| 6: Invalid File Handle'; |
| 12: Invalid File Access Code'; |
| 15: Invalid Drive Number'; |
| 16: Cannot Remove Current Directory' |
| 17: Cannot Rename Across Drives'; |
| 18: File access error'; |
| 100: Disk Read Error'; |
| 101: Disk Write Error'; |
| 102: File Not Assigned'; |
| 103: File Not Open'; |
| 104: File Not Open For Input'; |
| 105: File Not Open For Output'; |
| 106: Invalid Numeric Format'; |
| 150: Disk Is Write-Protected'; |
| 151: Unknown Unit'; |
| 152: Drive Not Ready'; |
| 153: Unknown Command'; |
| 154: CRC Error In Data'; |
| 155: Bad Drive Request Structure Leng |
| 156: Disk Seek Error'; |
| 157: Unknown Media Type'; |
| 158: Sector Not Found'; |
| 159: Printer Out Of Paper'; |
| 160: Device Write Fault'; |
| 161: Device Read Fault'; |
| 162: Hardware Failure'; }
Function Qprinter_ok :boolean;
Procedure Qwindow(lx,ly,rx,ry :integer;kleur :byte);
Procedure Qopen_window(x,y,xx,yy,color,back: Byte);
Procedure Qclose_window;
Function Upcase_string(regel :string):string;
{ Upcase hole string }
Function Upcase_First_char(regel :string):string;
{ Upcase only the first character of a string }
Function Lowcase_string(regel :string):string;
{ Put string in lowercase characters }
IMPLEMENTATION
uses crt,dos;
var
s,ss : String;
ch : char;
IS : Byte;
x,y,p : integer;
Orig_Pal : Array[0..255] Of Dac_Trio; { fade in/out }
regs : registers;
newCharset,
oldCharset : Array[0..255,1..16] of Byte; { voor Qread / Qreset_char }
raam : array[0..MaxVensters] of VensterPtr;
VideoVenster : VensterPtr;
VenTeller : Byte;
dac1,dac2 : DacType;
erg,gesamt : Word; { textfadein /out }
Procedure Qread_char;{*****************************************************}
Var
b:Byte;
w:Word;
begin
For b := 0 to 255 do begin
w := b * 32;
Inline($FA);
PortW[$3C4] := $0402;
PortW[$3C4] := $0704;
PortW[$3CE] := $0204;
PortW[$3CE] := $0005;
PortW[$3CE] := $0006;
Move(Ptr($A000, w)^, oldCharset[b, 1], 16);
PortW[$3C4] := $0302;
PortW[$3C4] := $0304;
PortW[$3CE] := $0004;
PortW[$3CE] := $1005;
PortW[$3CE] := $0E06;
Inline($FB);
end;
end;
Procedure Qreset_char;
Var
b:Byte;
w:Word;
begin
For b := 0 to 255 do begin
w := b * 32;
Inline($FA);
PortW[$3C4] := $0402;
PortW[$3C4] := $0704;
PortW[$3CE] := $0204;
PortW[$3CE] := $0005;
PortW[$3CE] := $0006;
Move(oldCharset[b, 1], Ptr($A000, w)^, 16);
PortW[$3C4] := $0302;
PortW[$3C4] := $0304;
PortW[$3CE] := $0004;
PortW[$3CE] := $1005;
PortW[$3CE] := $0E06;
Inline($FB);
end;
end;
procedure Qfont0;
begin
for p := 1 to 30 do With regs do begin
ah := $11;
al := $0;
bh := $10;
bl := 0;
cx := 1;
dx := NewChars[p].CN;
es := seg(NewChars[p].CD);
bp := ofs(NewChars[p].CD);
intr($10,regs);
end;
end;
procedure Qfont1; { Alle Karakters 1..80 zonder mijn naam }
begin
for p := 1 to 80 do With regs do begin
ah := $11;
al := $0;
bh := $10;
bl := 0;
cx := 1;
dx := NewChars[p].CN;
es := seg(NewChars[p].CD);
bp := ofs(NewChars[p].CD);
intr($10,regs);
end;
end;
procedure Qfont_jos; { zet mijn naam in tpu bestand }
begin
for p := 81 to 101 do With regs do begin { laatste 21 karakters }
ah := $11;
al := $0;
bh := $10;
bl := 0;
cx := 1;
dx := NewChars[p].CN;
es := seg(NewChars[p].CD);
bp := ofs(NewChars[p].CD);
intr($10,regs);
end;
end;
procedure QCursor(Ctype: Word); assembler;
asm
mov ax, $0100
mov cx, CType
int $10
end;
Function Left(s: String;nr: byte): String;
begin
Delete(s,nr+1,length(s));
Left:=s;
end;
Function Mid(s: String;nr,nr2: byte): String;
begin
Delete(s,1,nr-1);
Delete(s,nr2+1,length(s));
Mid:=s;
end;
Procedure WriteXY(x,y: Byte;s: String);
var
loop: Word;
begin
for loop:=x to x+length(s)-1 do
Mem[$B800:(loop-1)*2+(y-1)*160]:=Ord(S[loop-x+1]);
end;
Function RepeatChar(s: String;antal: byte): String;
var
temp: String;
begin
temp:=s[1];
While Length(temp)<Antal do Insert(s[1],temp,1);
RepeatChar:=Temp;
end;
Function qInput(X,Y: Byte;StartStr,BackG,PassChar: String;MaxLen,StartPos:
Integer;AcceptSet: CharSet;Ins: Boolean;var InputStatus: Byte):string;
Var
P : Byte;
Exit : Boolean;
ext : Char;
t : String[1];
begin
Exit:=False;
if Length(PassChar)>1 then PassChar:=PassChar[1];
if Length(BackG)>1 then BackG:=BackG[1];
if Length(BackG)=0 then BackG:=' ';
if Length(StartStr)>MaxLen then StartStr:=Left(StartStr,MaxLen);
if StartPos>Length(StartStr) then StartPos:=Length(StartStr);
if StartPos=-1 then StartPos:=Length(StartStr);
If StartPos>=MaxLen then StartPos:=MaxLen-1;
s:=StartStr;
WriteXY(X,Y,RepeatChar(BackG,MaxLen));
if StartStr<>'' then begin
if passchar='' then WriteXY(X,Y,StartStr) else
WriteXY(X,Y,RepeatChar(PassChar,Length(StartStr)));
end;
p:=StartPos;
GotoXY(X+StartPos,Y);
repeat
if Ins then Qcursor(norm) else Qcursor(bar);
ext:=#0;
ch:=ReadKey;
if ch=#0 then ext:=ReadKey;
if ch=#27 then begin
InputStatus:=27;
Exit:=True;
end;
if ch in AcceptSet then begin
t:=ch;
if (p=length(s)) and (Length(s)<MaxLen) then begin
s:=s+t;
if PassChar='' then WriteXY(X+P,Y,T) else
WriteXY(X+P,Y,PassChar);
Inc(p);
end else if length(s)<MaxLen then begin
if Ins then Insert(T,S,P+1) else s[p+1]:=Ch;
if PassChar='' then WriteXY(X+P,Y,Copy(S,P+1,Length(S)))
else WriteXY(X+Length(S)-1,Y,PassChar);
Inc(p);
end else if (Length(s)=MaxLen) and (not Ins) then begin
s[p+1]:=ch;
if PassChar='' then WriteXY(X+P,Y,T) else
WriteXY(X+P,Y,PassChar);
Inc(p);
end;
ch:=#0;
if p>MaxLen-1 then p:=MaxLen-1;
GotoXY(X+P,Y);
end else begin
case ch of { CTRL-Y }
#25: begin
WriteXY(X,Y,RepeatChar(BackG,Length(S)));
P:=0;
S:='';
GotoXY(X,Y);
end;
{Backspace}
#8: If (P>0) then begin
if (p+1=MaxLen) and (p<length(s)) then Ext:=#83 else begin
Delete(S,P,1);
Dec(P);
GotoXY(X+P,Y);
if PassChar='' then WriteXY(X+P,Y,Copy(S,P+1,Length(s))+BackG)
else if P>0 then WriteXY(X+Length(s)-1,Y,PassChar+BackG) else
WriteXY(X+Length(s),Y,BackG);
end;
end;
#9: begin { Exit on TAB }
InputStatus:=9;
Exit:=True;
end;
#13: begin
InputStatus:=13;
Exit:=True;
end;
end; { Case CH of }
case ext of
{Left Arrow}
#75: if P>0 then begin
Dec(P);
GotoXY(X+P,Y);
end;
{Right Arrow}
#77: if (P<Length(s)) and (P+1<MaxLen) then begin
Inc(P);
GotoXY(X+P,Y);
end;
#82: Ins:=Not(Ins); {Insert}
{Delete}
#83: If P<Length(s) then begin
Delete(S,P+1,1);
if PassChar='' then WriteXY(X+P,Y,Copy(S,P+1,Length(s))+BackG) else
if p>0 then WriteXY(X+Length(S)-1,Y,PassChar+BackG) else
WriteXY(X+Length(S),Y,BackG);
end;
#71: begin
p:=0;
GotoXY(X+P,Y);
end;
#79: begin
p:=Length(s);
if p>=MaxLen then P:=MaxLen-1;
GotoXY(X+P,Y);
end;
#72,#73,#80,#81,#59..#68:
begin
InputStatus:=Ord(Ext);
Exit:=True;
end;
end; {Case of EXT }
end; { if not normal char }
until Exit;
qinput:=S;
Qcursor(off);
end;
function Qstring(x,y,color,maxlen :byte;AcceptSet: CharSet):string;
label start;
var
posx :byte;
begin
Qcursor(on);
ss :='';posx :=1;
repeat
start:
gotoxy(x,y);
ch :=readkey;
if (ch =#8) and (posx+x-1 >x) then begin
dec(posx);
delete(ss,posx,1);
dec(x,1);
gotoxy(x,y);write(' ');
goto start;
end;
if (ch in AcceptSet) and (posx <maxlen) then begin
s :=ch;insert(s,ss,posx);
Qtext(x,y,s,color,0);
inc(x,1);
inc(posx);
end;
until ch in[#13];
Qstring :=ss;
Qcursor(off);
end;
procedure Qtext(x,y :byte;str :string;kleur,achtergrondkleur : Byte);
begin
textbackground(achtergrondkleur);
textcolor(kleur);
gotoxy(x,y);write(str);
textbackground(0);
end;
procedure Qwrite(x, y: byte; s: string; f, b: byte);
begin
asm
mov dh, y { move X and Y into DL and DH }
mov dl, x
xor al, al
mov ah, b { load background into AH }
mov cl, 4 { shift background over to next nibble }
shl ax, cl
add ah, f { add foreground }
push ax { PUSH color combo onto the stack }
mov bx, 0040h { look at 0040h:0049h to get video mode }
mov es, bx
mov bx, 0049h
mov al, es:[bx]
cmp al, 7 { see if mode = 7 (i.e., monochrome) }
je @mono_segment
mov ax, 0b800h { it's color: use segment B800h }
jmp @got_segment
@mono_segment:
mov ax, 0b000h { it's mono: use segment B000h }
@got_segment:
push ax { PUSH video segment onto stack }
mov bx, 004ah { check 0040h:0049h to get number of screen columns }
xor ch, ch
mov cl, es:[bx]
xor ah, ah { move Y into AL; decrement to convert Pascal coords }
mov al, dh
dec al
xor bh, bh { shift X over into BL; decrement again }
mov bl, dl
dec bl
cmp cl, $50 { see if we're in 80-column mode }
je @eighty_column
mul cx { multiply Y by the number of columns }
jmp @multiplied
@eighty_column: { 80-column mode: it may be faster to perform the }
mov cl, 4 { multiplication via shifts and adds: remember }
shl ax, cl { that 80d = 1010000b , so one can SHL 4, copy }
mov dx, ax { the result to DX, SHL 2, and add DX in. }
mov cl, 2
shl ax, cl
add ax, dx
@multiplied:
add ax, bx { add X in }
shl ax, 1 { multiply by 2 to get offset into video segment }
mov di, ax { video pointer is in DI }
lea si, s { string pointer is in SI }
SEGSS lodsb
cmp al, 00h { if zero-length string, jump to end }
je @done
mov cl, al
xor ch, ch { string length is in CX }
pop es { get video segment back from stack; put in ES }
pop ax { get color back from stack; put in AX (AH = color) }
@write_loop:
SEGSS lodsb { get character to write }
mov es:[di], ax { write AX to video memory }
inc di { increment video pointer }
inc di
loop @write_loop { if CX > 0, go back to top of loop }
@done: { end }
end;
end;
procedure qhor_write(x,y,aantal,teken,kleur :byte);
begin
for p :=1 to aantal do qwrite(x+p-1,y,chr(teken),kleur,0);
end;
procedure qver_write(x,y,aantal,teken,kleur :byte);
begin
for p :=1 to aantal do qwrite(x,y+p-1,chr(teken),kleur,0);
end;
procedure qhor(x,y,aantal,teken,kleur :byte);
begin
for p :=1 to aantal do qtext(x+p-1,y,chr(teken),kleur,0);
end;
procedure qver(x,y,aantal,teken,kleur :byte);
begin
for p :=1 to aantal do qtext(x,y+p-1,chr(teken),kleur,0);
end;
procedure Qtime(x,y,kleur,achtergrondkleur :byte);
function leadingzero(w :word) :string;
var
st :string;
begin
str(w:0,st);if length(st) =1 then st :='0' +st;leadingzero :=st;
end;
var
h,m,s,hund :word;
begin
textbackground(achtergrondkleur);
textcolor(kleur);gettime(h,m,s,hund);gotoxy(x,y);
writeln(' ', leadingzero(h), ':',
leadingzero(m), ':',
leadingzero(s), ' ');
textbackground(0);
end;
procedure Qdate(x,y,kleur,achtergrondkleur :byte);
var
j,m,d,w :word;
begin
textbackground(achtergrondkleur);
textcolor(kleur);getdate(j,m,d,w);gotoxy(x,y);write(d,'/',m,'/',j);
textbackground(0);
end;
function Qday_Of_Week(Month,Day,Year :WORD):byte;
var
ivar1,ivar2 :Integer;
begin
IF (Day > 0) AND (Day < 32) AND (Month > 0) AND (Month < 13) then begin
ivar1 := ( Year MOD 100 );
ivar2 := Day + ivar1 + ivar1 DIV 4;
CASE Month OF
4, 7 : ivar1 := 0;
1, 10 : ivar1 := 1;
5 : ivar1 := 2;
8 : ivar1 := 3;
2,3,11 : ivar1 := 4;
6 : ivar1 := 5;
9,12 : ivar1 := 6;
END;
ivar2 := ( ivar1 + ivar2 ) MOD 7;
IF ( ivar2 = 0 ) THEN ivar2 := 7;
END
ELSE
ivar2 := 0;
Qday_Of_Week := BYTE( ivar2 );
end;
Function NumbofDaysInMth(y,m : Word): Byte;
begin
Case m of
1,3,5,7,8,10,12: NumbofDaysInMth := 31;
4,6,9,11 : NumbofDaysInMth := 30;
2 : NumbofDaysInMth := 28 +
ord((y mod 4) = 0);
end;
end;
procedure Qscreen_off;
begin
regs.ah := $12; { 12 = vgahi 640 x 480 }
regs.al := ord(1); { 0 = on, 1 = off }
regs.bl := $36; { Subfunction }
intr($10, regs); { Call BIOS }
end;
procedure Qscreen_on;
begin
regs.ah := $12; { 12 = vgahi 640 x 480 }
regs.al := ord(0); { 0 = on, 1 = off }
regs.bl := $36; { Subfunction }
intr($10, regs); { Call BIOS }
end;
Procedure Qdelay(ms : Word); Assembler;
Asm
mov ax, 1000;
mul ms;
mov cx, dx;
mov dx, ax;
mov ah, $86;
int $15;
end;
procedure Qfill_screen(char,color :byte);
begin
regs.ah :=9;
regs.al :=char;
regs.bh :=0;
regs.bl :=color;
regs.ch :=7;
regs.cl :=208;
intr(16,regs);
textbackground(0);
end;
procedure Qborder(kleur: byte);
begin
regs.ah:=$10;
regs.al:=$01;
regs.bh:=kleur;
Intr(16,regs)
end;
Procedure Qsave_screen(FileName: String);
var
AScreen : ScreenPtr;
f : FILE;
begin
if(LastMode = Mono) then AScreen := PTR($B000,0)
else AScreen := PTR( $B800,0);
assign(f,filename);
rewrite(f,1);
blockwrite(f,AScreen^,SIZEOF(AScreen^));
close(f);
end;
Procedure Qload_screen(FileName: String);
var
AScreen : ScreenPtr;
f : FILE;
begin
assign(f,filename);
{$I-} reset(f,1); {$I+}
if ioresult <>0 then exit;
blockread(f,AScreen^,SIZEOF(AScreen^));
close(f);
end;
procedure Qscroll(x,y :byte;s:string;back,textcolor,highlight,dlay,
waitkey:word);
var
l,direction : byte;
c : char;
begin
regs.ax:= $0100; regs.cx:= $2607; intr($10,regs); { hide cursor }
direction:= 1; l:= 1;
gotoxy(x,y);
textattr:= textcolor+back*16;
write(s);
while (keypressed=FALSE) AND (direction>0) do begin
if direction=1 then begin
inc(l);
if l=length(s) then direction:= 2;
end else begin
dec(l);
if l=1 then direction:= 1;
if (WaitKey=0) AND (direction=1) then begin
direction:=0;
gotoxy(x,y);
textattr:= highlight+back*16;
write(s[1]);
Qdelay(dlay);
end;
end;
if direction>0 then begin
gotoxy(x+(l-1),y);
textattr:= highlight+back*16;
c:= s[l];
if (c>#96) AND (c<#123) then c:= chr(ord(c)-32);
write(c);
textattr:= textcolor+back*16;
Qdelay(dlay);
gotoxy(x+(l-1),y);
write(s[l]);
end;
end;
gotoxy(x,y);
textattr:= textcolor+back*16;
writeln(s);
regs.ax:= $0100; regs.cx:= $0506; intr($10,regs); { restore cursor }
end;
Procedure WaitForRetrace;
Begin
Asm
MOV DX,$3DA;
@Wait1:
IN AL,DX
TEST AL,8 {retrace hapening?}
JNZ @Wait1 {Yep, wait for it to end}
@Wait2:
IN AL,DX
TEST AL,8 {Retrace happening?}
JZ @Wait2 {nope, wait to finish}
End
End;
Procedure SetPal(Var P; Start:Byte; Count:Word);
Begin
WaitForRetrace; {To eliminate snow.}
Asm
MOV DX,$3C8
MOV AL,Start
OUT DX,AL
INC DX
MOV BX,DS
LDS SI,P
MOV CX,Count
ADD CX,Count
ADD CX,Count
REP OUTSB
MOV DS,BX
End;
End;
Procedure GetPal(Var P; Start:Byte; Count:Word);
Begin
Asm
MOV DX,$3C7
MOV AL,Start
OUT DX,AL
INC DX
INC DX
MOV BX,ES
LES DI,P
MOV CX,Count
ADD CX,Count
ADD CX,Count
REP INSB
MOV ES,BX
End;
End;
Procedure QFade_Out;
Var
Pal : Array[0..255] Of Dac_Trio;
Loop1,Loop2 : Byte;
Begin
GetPal(Orig_Pal,0,256); { Make a copy of origonal pallette }
GetPal(Pal,0,255);
For Loop1:=1 To 64 Do Begin
For Loop2:=0 To 255 Do Begin
If Pal[Loop2].Red>0 Then Dec(Pal[Loop2].Red);
If Pal[Loop2].Green>0 Then Dec(Pal[Loop2].Green);
If Pal[Loop2].Blue>0 Then Dec(Pal[Loop2].Blue);
End;
WaitForRetrace;
SetPal(Pal,0,255);
End;
End;
Procedure QFade_In;
Var
NewPal : Array[0..255] Of Dac_Trio Absolute orig_pal;
Pal : Array[0..255] Of Dac_Trio;
Loop1,Loop2 : Byte;
Begin
FillChar(Pal,SizeOf(Pal),0); {Set to black}
SetPal(Pal,0,256);
For Loop1:=63 DownTo 0 Do Begin
For Loop2:=0 To 255 Do Begin
If NewPal[Loop2].Red>Loop1 Then Inc(Pal[Loop2].Red);
If NewPal[Loop2].Green>Loop1 Then Inc(Pal[Loop2].Green);
If NewPal[Loop2].Blue>Loop1 Then Inc(Pal[Loop2].Blue);
End;
WaitForRetrace;
SetPal(Pal,0,255);
End;
End;
Function QGetChar(X,Y:Byte):Char;
Const
ColorSeg = $B800; (* For color system *)
MonoSeg = $B000; (* For mono system *)
begin
QGetChar := Chr(Mem[ColorSeg:160*(Y-1) + 2*(X-1)])
end;
procedure Qdel_file(filename :string);
var
f :file;
begin
assign(f,filename);
{$I-} reset(f); {$I+}
if ioresult = 0 then begin
close(f);
erase(f);
end;
end;
function Qexist_file(FileName : string) : boolean;
var
sr : SearchRec;
begin
FindFirst(FileName, AnyFile, sr);
QExist_File := (DosError = 0);
end;
function Qexist_dir(dir:string):boolean;
var
AktDir :string;
begin
IF Dir[Length(Dir)]='\' THEN Delete(Dir,Length(dir),1);
GetDir(0,AktDir);
{$I-} ChDir(Dir); {$I+}
QExist_Dir:=(IoResult=0);
ChDir(AktDir);
end;
procedure QGet_File_Attr(fn:string;var Attr:word);
var
Reg : Registers;
begin
fn:=fn+#0;
Reg.AX:=$4300;
Reg.DS:=Seg(fn[1]);
Reg.DX:=Ofs(fn[1]);
Intr($21,Reg);
Attr:=Reg.CX;
IF Odd(Reg.Flags) THEN
DosError:=Reg.AX
else
DosError:=WORD(0);
end;
procedure QSet_File_Attr(fn :string;Attr:word);
var
Reg : Registers;
begin
fn:=fn+#0;
Reg.AX:=$4301;
Reg.CX:=Attr;
Reg.DS:=Seg(fn[1]);
Reg.DX:=Ofs(fn[1]);
Intr($21,Reg);
IF Odd(Reg.Flags) THEN
DosError:=Reg.AX
else
DosError:=WORD(0);
end;
procedure QGet_File_Size(FName :string;var Fsize :longint;var Error :word);
var
SR : SearchRec;
begin
{$I-}
FindFirst(FName,Archive,SR);
Error := DosError;
{$I+}
if Error = 0 then
FSize := SR.Size
else
FSize := 0;
end;
procedure QCopy_file(file_of,file_to :string);
Var InFile, OutFile : File;
Buffer : Array[ 1..1024 ] Of Char;
NumberRead,
NumberWritten : Word;
begin
Assign(InFile,file_of);
{$I-} Reset(InFile,1); {$I+} { neemt bestand van c: }
if ioresult <>0 then exit; { als bestand niet is gevonden }
Assign(OutFile,file_to); { bestand voor a: }
ReWrite(OutFile,1);
Repeat
BlockRead ( InFile, Buffer, Sizeof( Buffer ), NumberRead );
BlockWrite( OutFile, Buffer, NumberRead, NumberWritten );
Until (NumberRead = 0) or (NumberRead <> NumberWritten);
Close(InFile);
Close(OutFile);
end;
procedure Qclear_buffer;
begin
memw[$0000:$041C] :=memw[$0000:$041A];
end;
function Qread_key :word;
var
Value : word;
begin
repeat until KeyPressed;
Value := Ord(ReadKey);
if Value = 0
then Value := Ord(ReadKey) + 256;
Qread_key := Value;
end;
procedure Qsound(freq,delay :integer);
begin
sound(freq);Qdelay(delay);nosound;
end;
procedure Qinfo(regel :string);
const
lett : array[65..90] of string[1] =('A','B','C','D','E','F','G','H',
'I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z');
var
kleur : byte;
aantal : integer;
begin
x :=40-(round(length(regel)/2));
Qhor(4,23,74,219,0);
for p :=1 to length(regel) do begin { zoekt de hoofdletters op }
s :=copy(regel,p,1);
kleur :=7; { en zet deze om in een }
for aantal :=65 to 90 do begin { andere kleur }
if lett[aantal]=s then kleur :=13;
end;
gotoxy(x+1,23);
textbackground(0);
textcolor(kleur);
write(s);
inc(x);
end;
textbackground(0);
end;
procedure Qwindow(lx,ly,rx,ry :integer;kleur :byte);
begin
textcolor(kleur);
window(lx,ly,rx,ry);clrscr;window(lx,ly,rx+1,ry);
gotoxy(1,1);write(chr(218)); { linksboven }
for p :=1 to ((rx -lx) -1) do write(chr(194)); { boven }
write(chr(191)); { rechtsboven }
for p :=1 to ((ry -ly) -1) do begin
gotoxy(1,1 +p);write(chr(195)); { links }
gotoxy((rx -lx)+1,1 +p);write(chr(180)); { rechts }
end;
gotoxy(1,(ry -ly) +1);write(chr(192)); { linksonder }
for p :=1 to ((rx -lx) -1) do write(chr(193)); { onder }
write(chr(217)); { rechtsonder }
window(1,1,80,25);
end;
procedure read_dacs(Var Dac : DacType);
begin
regs.ax := $1017;
regs.bx := 0;
regs.cx := 256;
regs.es := SEG(Dac);
regs.dx := Ofs(Dac);
Intr($10, regs);
end;
procedure write_dacs(Dac : DacType);
begin
regs.ax := $1012;
regs.bx := 0;
regs.cx := 256;
regs.es := seg(Dac);
regs.dx := Ofs(Dac);
Intr($10, regs);
end;
procedure Qfadeout(Speed : Integer);
begin;
Repeat
erg := 0;
For x := 1 to 256 do
For y := 1 to 3 do
begin
if dac2[x, y] > 0 then
DEC(dac2[x, y]);
erg := erg + dac2[x, y];
end;
Write_Dacs(dac2);
Qdelay(Speed);
Until erg = 0;
end;
procedure QfadeIn(Speed : Integer);
begin;
Repeat
erg := 0;
For x := 1 to 256 do
For y := 1 to 3 do
begin
if dac2[x, y] < dac1[x, y] then
INC(dac2[x,y]);
erg := erg + dac2[x, y];
end;
Write_Dacs(dac2);
Qdelay(Speed);
Until (erg = gesamt) or (KeyPressed);
Write_Dacs(dac1);
end;
function Qerror(ErrorCode :INTEGER):STRING;
begin
case ErrorCode OF
0: QError := 'No Error';
2: QError := 'File Not Found';
3: QError := 'Path Not Found';
4: QError := 'Too Many Open Files';
5: QError := 'File Access Denied';
6: QError := 'Invalid File Handle';
12: QError := 'Invalid File Access Code';
15: QError := 'Invalid Drive Number';
16: QError := 'Cannot Remove Current Directory';
17: QError := 'Cannot Rename Across Drives';
18: QError := 'File access error';
100: QError := 'Disk Read Error';
101: QError := 'Disk Write Error';
102: QError := 'File Not Assigned';
103: QError := 'File Not Open';
104: QError := 'File Not Open For Input';
105: QError := 'File Not Open For Output';
106: QError := 'Invalid Numeric Format';
150: QError := 'Disk Is Write-Protected';
151: QError := 'Unknown Unit';
152: QError := 'Drive Not Ready';
153: QError := 'Unknown Command';
154: QError := 'CRC Error In Data';
155: QError := 'Bad Drive Request Structure Length';
156: QError := 'Disk Seek Error';
157: QError := 'Unknown Media Type';
158: QError := 'Sector Not Found';
159: QError := 'Printer Out Of Paper';
160: QError := 'Device Write Fault';
161: QError := 'Device Read Fault';
162: QError := 'Hardware Failure';
end;
end;
function Qprinter_ok :boolean;
begin
If (Port[$379]) And (16) <> 16 Then
QPrinter_OK := False
Else
QPrinter_OK := True;
end;
{******************************* RAAM *************************************}
function F_Video :Word;
var
Regs : REGISTERS;
begin
INTR($11, Regs);
if (Regs.AL and 48) = 48 then F_Video := $B000
else F_Video := $B800;
end;
procedure InitVensters;
begin
New(VideoVenster);
for p := 0 to MaxVensters do New(raam[p]);
with VideoVenster^ do begin
VenX1 := 0;
VenY1 := 0;
VenX2 := 82;
VenY2 := 26;
end;
VenTeller := 0;
raam[VenTeller]^ := VideoVenster^;
VideoVenster := Ptr(F_Video, $0000);
end;
procedure Kader1(x,y,xx,yy,ak :Byte); { voor kleur }
begin
textbackground(ak);
window(x,y,xx,yy);clrscr;window(x,y,xx+1,yy);
gotoxy(1,1);write(chr(218));
gotoxy(1,(yy-y+1));write(chr(192));
gotoxy((xx-x+1),1);write(chr(191));
gotoxy((xx-x+1),(yy-y+1));write(chr(217));
for p := 2 to(xx-x) do begin gotoxy(p,1);write(chr(194));end;
for p := 2 to(xx-x) do begin gotoxy(p,(yy-y+1));write(chr(193));end;
for p := 2 to(yy-y) do begin gotoxy(1,p);write(chr(195));end;
for p := 2 to(yy-y) do begin gotoxy((xx-x+1),p);write(chr(180));end;
window(x+1,y+1,xx-2,yy-1);
textbackground(0);
end;
procedure Kader2(x,y,xx,yy,ak :Byte); { voor monocroom }
begin
textbackground(ak);
window(x,y,xx,yy);clrscr;window(x,y,xx+1,yy);
gotoxy(1,1);write(chr(218));
gotoxy(1,(yy-y+1));write(chr(192));
gotoxy((xx-x+1),1);write(chr(191));
gotoxy((xx-x+1),(yy-y+1));write(chr(217));
for p := 2 to(xx-x) do begin gotoxy(p,1);write(chr(196));end;
for p := 2 to(xx-x) do begin gotoxy(p,(yy-y+1));write(chr(196));end;
for p := 2 to(yy-y) do begin gotoxy(1,p);write(chr(179));end;
for p := 2 to(yy-y) do begin gotoxy((xx-x+1),p);write(chr(179));end;
window(x+1,y+1,xx-2,yy-1);
textbackground(0);
end;
procedure Qopen_window(x,y,xx,yy,color,back :Byte);
begin
textcolor(color);
if (VenTeller < MaxVensters) and (x < xx) and (x >= 1) and
(xx <= 80) and (y < yy) and (y >= 1) and (yy <= 25) then begin
raam[VenTeller]^.Data :=VideoVenster^.Data;
raam[VenTeller]^.XPos :=WHEREX;
raam[VenTeller]^.YPos :=WHEREY;
Inc(VenTeller);
WINDOW(x+1,y+1,xx-2,yy-1);
with raam[VenTeller]^ do begin
VenX1 := x;
VenY1 := y;
VenX2 := xx;
VenY2 := yy;
end;
if f_video =$B800 then kader1(x,y,xx,yy,back)
else kader2(x,y,xx,yy,back);
end
else begin
window(1,1,80,25);clrscr;
gotoxy(3,5);
write('FOUT MET VENSTERS ');
delay(1000);
end;
end;
procedure Qclose_window;
begin
if VenTeller > 0 then begin
Dec(VenTeller);
VideoVenster^.Data :=raam[VenTeller]^.Data;
with raam[VenTeller]^ do begin
WINDOW(VenX1+1,VenY1+1,VenX2-2,VenY2-1);
GOTOXY(XPos, YPos);
end;
end
else begin
CLRSCR;
GOTOXY(3, 5);
Write('GEEN VENSTER AANWEZIG ');
DELAY(1000);
end;
end;
Function Upcase_string(regel :string):string;
begin
for p :=1 to length(regel) do regel[p] :=upcase(regel[p]);
Upcase_string :=regel;
end;
Function Upcase_First_char(regel :string):string;
begin
regel :=lowcase_string(regel);
s :=copy(regel,1,1);
for p :=1 to length(s) do s[p] :=upcase(s[p]);
delete(regel,1,1);
insert(s,regel,1);
Upcase_First_char :=regel;
end;
Function Lowcase_string(regel:String):string;
Function DWNCase(DWNCH:Char):Char;
begin
if dwnch in['A'..'Z'] then dwncase :=chr(ord(dwnch)+32)
else dwncase :=dwnch;
end;
begin
For p:=1 to LENGTH(regel) do regel[p]:=DWNCase(regel[p]);
lowcase_string :=regel;
end;
begin
textmode(CO80);
InitVensters;
Read_Dacs(dac1);
dac2 := dac1;
gesamt := 0;
For x := 1 to 256 do For y := 1 to 3 do gesamt := gesamt + dac1[x, y];
{ The authors name in the beginning of this unit
Qcursor(off);
Qfill_screen(219,0);
clrscr;
Qread_char;
Qfont_jos;
gotoxy(26,12);textcolor(12);
writeln('Ò¾ Ÿòâ«œ³úú ¾¡þ‚³¬ý ÷Çé øßß¿');
Qdelay(1000);
Qfadeout(10);
Qreset_char;
clrscr;
Qfadein(0);
}
end.
