{$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.

Published in: Pascal
Download

Related snippets