home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / ECO30603.ZIP / ECO30603.LZH / ECOLIBII / ECO_CRT / ECO_CRT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-06  |  27.2 KB  |  985 lines
  1. {$UNDEF DEBUG}
  2. {$A+,B-,E+,F-,N-,O-,R-,V-,I-}
  3. {$IFDEF DEBUG} {$D+,L+,S+} {$ELSE} {$D-,L-,S-} {$ENDIF}
  4. unit eco_crt;
  5.  
  6. interface
  7.  
  8. uses
  9.   eco_adpt
  10.  
  11.   ;
  12.  
  13. const
  14.   bw40                      = 0;{40x25 b/w on cga}
  15.   co40                      = 1;{40x25 color on cga}
  16.   bw80                      = 2;{80x25 b/w on cga}
  17.   co80                      = 3;{80x25 color on cga}
  18.   mono                      = 7;{80x25 b/w on mda or hgc}
  19.   font8x8                   = 256;{43-/50-line mode ega/vga}
  20.   co132x25                  = 85;{color 132x25 line mode ega paradise 480}
  21.   co132x43                  = 84;{color 132x43 line mode ega paradise 480}
  22.   mo132x25                  = 86;{mono 132x25 line mode ega paradise 480}
  23.   mo132x43                  = 87;{mono 132x43 line mode ega paradise 480}
  24.   c40                       = co40;{for 3.0 compatibility}
  25.   c80                       = co80;{for 3.0 compatibility}
  26.  
  27.   black                     = $00;
  28.   blue                      = $01;
  29.   green                     = $02;
  30.   cyan                      = $03;
  31.   red                       = $04;
  32.   magenta                   = $05;
  33.   brown                     = $06;
  34.   lightgray                 = $07;
  35.   darkgray                  = $08;
  36.   lightblue                 = $09;
  37.   lightgreen                = $0a;
  38.   lightcyan                 = $0b;
  39.   lightred                  = $0c;
  40.   lightmagenta              = $0d;
  41.   yellow                    = $0e;
  42.   white                     = $0f;
  43.   blink                     = $80;
  44.  
  45.   blackbg                   = $00;
  46.   bluebg                    = $10;
  47.   greenbg                   = $20;
  48.   cyanbg                    = $30;
  49.   redbg                     = $40;
  50.   magentabg                 = $50;
  51.   brownbg                   = $60;
  52.   lightgraybg               = $70;
  53.  
  54.  
  55. type
  56.   adaptertype = (
  57.     none,mda,hercules,cga,egamono,egacolor,mcgamono,mcgacolor,
  58.     vgamono,vgacolor
  59.   );
  60.   
  61.   charset     = set of char; {makkelijk}
  62.  
  63.   stscreen    = string[132]; {max screen lengte i know is possible}
  64.   bordertypes               = (nobrdr,
  65.                                spacebrdr,singlebrdr,doublebrdr,
  66.                                horizdoublevertsinglebrdr,
  67.                                horizsinglevertdoublebrdr,
  68.                                hatch1brdr,hatch2brdr,hatch3brdr);
  69.  
  70.   borders                   = (horiztop, horizbottom,
  71.                                vertleft, vertright, horizborders,
  72.                                vertborders, allborders);
  73.   borderparts               = (tl,tr,bl,br,ht,hb,vr,vl,lc,rc,tc,bc,cc);
  74.   borderarray               = array[tl..cc] of char;
  75.  
  76. const
  77.   borderst : array [spacebrdr..hatch3brdr] of borderarray = (
  78.     '█████████████',
  79.     '┌┐└┘──││├┤┬┴┼',
  80.     '╔╗╚╝══║║╠╣╦╩╬',
  81.     '╒╕╘╛══││╞╡╤╧╪',
  82.     '╓╖╙╜──║║╟╢╥╙╫',
  83.     '░░░░░░░░░░░░░',
  84.     '▒▒▒▒▒▒▒▒▒▒▒▒▒',
  85.     '▓▓▓▓▓▓▓▓▓▓▓▓▓'
  86.    );
  87.  
  88. type
  89.   largearray     = array [1..32000] of word;
  90.  
  91.   savescrptr     = ^savescrrec;
  92.   savescrrec     = record
  93.    screensize   : word;
  94.    savedscr     : largearray;
  95.   end;
  96.  
  97.   quickwindowptr = ^quickwindowrec;
  98.   quickwindowrec = record
  99.    previous      : quickwindowptr; { is nil when last window }
  100.    windowinfo    : savescrptr; { window size,saved screen }
  101.    x1,y1,
  102.    x2,y2         : byte; { absolute screen coordiantes }
  103.    bt            : bordertypes;
  104.    sscrolllock   : boolean; { saved scrolllock status }
  105.    signorewindow : boolean; { saved ignorewindow }
  106.    sscanlines    : word; { cursor scan lines }
  107.    sx,sy         : byte; { cursor position }
  108.    swindmin,
  109.    swindmax      : word; { saved previous window }
  110.    stextattr     : byte; { saved textattr }
  111.   end;
  112.  
  113.  
  114. var
  115.   checksnow          : boolean absolute eco_adpt.checksnow;{for snow on cga}
  116.   textattr           : byte;{back and foreground color}
  117.   windmin            : word;{window coordinaten}
  118.   windmax            : word;
  119.   lastmode           : word absolute eco_adpt.currenttextmode;
  120.  
  121.   (* extra vars not in borland's CRT *)
  122.   videopage          : byte absolute eco_adpt.videopage;{video page number}
  123.   videocard          : adaptertype absolute eco_adpt.videocard; {video kaart}
  124.   maxrows            : byte absolute eco_adpt.maxrows;{current max number }
  125.   maxcols            : byte absolute eco_adpt.maxcols;{ of colums and lines}
  126.   videoofs           : word absolute eco_adpt.videoofs;{offset video memory}
  127.   videoseg           : word absolute eco_adpt.videoseg;{start video memory}
  128.   videoptr           : pointer absolute eco_adpt.videoptr;
  129.   scrolllockscreen   : boolean;{scroll screen;normaal is false}
  130.   startupmode        : word absolute eco_adpt.startupmode;{videomode at startup time}
  131.   startupcursorsize  : word absolute eco_adpt.startupcursorsize;
  132.   ignorewindow       : boolean; { if true abs screen coordinates are in use }
  133.   visiblequickwindow : quickwindowptr; { active quick window }
  134.  
  135.  
  136.   procedure textmode(mode : integer);
  137.   
  138.   procedure window(x1,y1,x2,y2 : byte);
  139.   procedure clrscr;
  140.   procedure clrline(y : byte);
  141.   procedure clreol;
  142.   
  143.   procedure delline;
  144.   procedure insline;
  145.   
  146.   procedure normvideo;
  147.   procedure lowvideo;
  148.   procedure highvideo;
  149.   
  150.   procedure textbackground(color : byte);
  151.   procedure textcolor(color : byte);
  152.   
  153.   procedure gotoxy(x,y : byte);
  154.   function  wherey : byte;
  155.   function  wherex : byte;
  156.   procedure gotoxyabs(x,y : byte);
  157.   function  whereyabs : byte;
  158.   function  wherexabs : byte;
  159.   
  160.   function  windowcols : byte;
  161.   function  windowrows : byte;
  162.   
  163.   function  readword : word;
  164.    inline($b8/$00/$00/           { mov ax,0        }
  165.           $cd/$16);              { int 16h         }
  166.   
  167.   function  readkey : char;
  168.   function  keypressed : boolean;
  169.   
  170.   procedure delay(ms : word);
  171.   procedure sound(hz : word);
  172.   procedure nosound;
  173.   
  174.   procedure assigncrt(var f : text);
  175.   
  176.   function  location(x,y : byte) : word;
  177.   procedure fillword(var dest;width,value : word);
  178.   
  179.   procedure scrollup(x1,y1,x2,y2,color : byte);
  180.   procedure scrolldown(x1,y1,x2,y2,color : byte);
  181.   
  182.   procedure fastwrite(x,y,attr : byte;st : stscreen);
  183.   procedure fastpwrite(x,y : byte;st : stscreen);
  184.   procedure changeattr(x,y,attr,len : byte);
  185.   procedure titleengine(x1,y1,x2,y2 : byte;bt : bordertypes;
  186.                         var title : stscreen);
  187.   procedure boxengine(x1,y1,x2,y2,attr : byte;
  188.                       bordertype : bordertypes;filled : boolean);
  189.   
  190.   procedure movefromscreen(var source,dest;length : word);
  191.   procedure movetoscreen(var source,dest;length : word);
  192.   
  193.   (* cursor manipulation *)
  194.   procedure normalcursor;
  195.   procedure insertcursor;
  196.   procedure halfcursor;
  197.   procedure hidecursor;
  198.   
  199.   (* screen save/restore procedures *)
  200.   function  savepartscreen(x1,y1,x2,y2 : byte) : savescrptr;
  201.   procedure restorepartscreen(var scrptr : savescrptr;x1,y1,x2,y2 : byte);
  202.   procedure disposepartscreen(var scrptr : savescrptr);
  203.   
  204.   (* quick window interface *)
  205.   procedure quickopenwindow(x1,y1,x2,y2,attr : byte;bt : bordertypes;
  206.                             st : stscreen);
  207.   procedure quickmovewindow(x,y : byte);
  208.   procedure quickclosewindow;
  209.  
  210.  
  211.  
  212.   
  213. implementation
  214.  
  215.  
  216.  
  217.  
  218. const
  219.   fmclosed           = $d7b0;
  220.   fminput            = $d7b1;
  221.   fmoutput           = $d7b2;
  222.   fminout            = $d7b3;
  223.  
  224.  
  225. type
  226.   wordrec = record x,y  : byte end;
  227.  
  228.   textbuf        = array [0..127] of char;
  229.   textrec        = record
  230.     handle      : word;
  231.     mode        : word;
  232.     bufsize     : word;
  233.     private     : word;
  234.     bufpos      : word;
  235.     bufend      : word;
  236.     bufptr      : ^textbuf;
  237.     openfunc    : pointer;
  238.     inoutfunc   : pointer;
  239.     flushfunc   : pointer;
  240.     closefunc   : pointer;
  241.     userdata    : array [1..16] of byte;
  242.     name        : array [0..79] of char;
  243.     buffer      : textbuf;
  244.   end;
  245.  
  246.  
  247.  
  248. var
  249.   orginalexitproc : pointer; {saved exit proc of turbo pascal}
  250.  
  251.  
  252.  
  253.  
  254. (*----------------- start externals ----------------------------------------*)
  255. {$L CalcOfs.OBJ} {Don't use or call this proc it is of now use to you}
  256. procedure calcoffset; external; {is near used by screen writes asm routines}
  257. {$L FillVide.OBJ}
  258. procedure fillvideo; external; {is near used by screen writes asm routines}
  259. {$F+}
  260.  
  261. {$L Window.OBJ}
  262. procedure window(x1,y1,x2,y2 : byte); external;
  263.  
  264. {$L ClrScr.OBJ}
  265. procedure clrscr; external;
  266.  
  267. {$L ClrEol.OBJ}
  268. procedure clreol; external;
  269.  
  270. {$L Color.OBJ}
  271. procedure getstartupcolor; external;
  272. procedure normvideo; external;
  273.  
  274. {$L LowVideo.OBJ}
  275. procedure lowvideo; external;
  276.  
  277. {$L HighVide.OBJ}
  278. procedure highvideo; external;
  279.  
  280. {$L TXTColor.OBJ}
  281. procedure textcolor(color : byte); external;
  282.  
  283. {$L BGColor.OBJ}
  284. procedure textbackground(color : byte); external;
  285.  
  286. {$L Cursor.OBJ}
  287. procedure gotoxy(x,y : byte); external;
  288. function wherey : byte; external;
  289. function wherex : byte; external;
  290.  
  291. {$L AbsCurs.OBJ}
  292. procedure gotoxyabs(x,y : byte); external;
  293. function whereyabs : byte; external;
  294. function wherexabs : byte; external;
  295.  
  296. {$L Readkey.OBJ}
  297. function readkey : char; external;
  298. function keypressed : boolean; external;
  299.  
  300. {$L Delay.OBJ}
  301. procedure delay(ms : word); external;
  302. procedure delayinit; external;
  303.  
  304. {$L Sound.OBJ}
  305. procedure sound(hz : word); external;
  306. procedure nosound; external;
  307.  
  308. {$L MoveFrom.OBJ}
  309. procedure movefromscreen(var source,dest;length : word); external;
  310.  
  311. {$L MoveTo.OBJ}
  312. procedure movetoscreen(var source,dest;length : word); external;
  313.  
  314. {$L SwapVar.OBJ}
  315. procedure swapvar(var p1,p2;size : word); external;
  316.  
  317. {$L FastWrt.OBJ}
  318. procedure asmwrite(var scrptr;wid,col,row,attr : byte;st : string); external;
  319. procedure asmpwrite(var scrptr;wid,col,row : byte;st : string); external;
  320. procedure asmattr(var scrptr;wid,col,row,attr,len : byte); external;
  321.  
  322. {$F-}
  323. (*----------------- end externals -- start inlines -------------------------*)
  324.  
  325. function location(x,y : byte) : word;
  326. begin
  327.  inline($8b/$be/y/             {      mov     di,[bp+y]           }
  328.         $8b/$b6/x/             {      mov     si,[bp+x]           }
  329.         $4f/                   {      dec     di                  }
  330.         $4e/                   {      dec     si                  }
  331.         $a1/maxcols/           {      mov     ax,[maxcols]        }
  332.         $f7/$e7/               {      mul     di                  }
  333.         $01/$f0/               {      add     ax,si               }
  334.         $01/$c0/               {      add     ax,ax               }
  335.         $03/$06/videoofs/      {      add     ax,[videoofs]       }
  336.         $89/$86/location);     {      mov     [bp+location],ax    }
  337. end;
  338.  
  339. procedure fillword(var dest;width,value : word);
  340. begin
  341.  if checksnow then
  342.   inline($c4/$be/dest/            {         les     di,dest[bp]       }
  343.          $8b/$8e/width/           {         mov     cx,width[bp]      }
  344.          $8b/$9e/value/           {         mov     bx,value[bp]      }
  345.          $fc/                     {         cld                       }
  346.          $e3/$16/                 {         jcxz    ready             }
  347.          $ba/$03da/               {         mov     dx,3dah           }
  348.          $b4/$09/                 {         mov     ah,9              }
  349.          $ec/                     { test1:  in      al,dx             }
  350.          $d0/$d8/                 {         rcr     al,1              }
  351.          $72/$fb/                 {         jb      test1             }
  352.          $fa/                     {         cli                       }
  353.          $ec/                     { test2:  in      al,dx             }
  354.          $22/$c4/                 {         and     al,ah             }
  355.          $74/$fb/                 {         jz      test2             }
  356.          $8b/$c3/                 {         mov     ax,bx             }
  357.          $ab/                     {         stosw                     }
  358.          $fb/                     {         sti                       }
  359.          $e2/$ef) else            {         loop    test1             }
  360.                                   { ready:                            }
  361.   inline($c4/$be/dest/            {         les     di,dest[bp]       }
  362.          $8b/$8e/width/           {         mov     cx,width[bp]      }
  363.          $8b/$86/value/           {         mov     ax,value[bp]      }
  364.          $fc/                     {         cld                       }
  365.          $f3/$ab);                {         rep     stosw             }
  366. end;
  367.  
  368. (*----------------- end inlines --------------------------------------------*)
  369.  
  370. procedure textmode(mode : integer);
  371. begin
  372.  settextmode(mode);
  373.  window(1,1,maxcols,maxrows);
  374. end;
  375.  
  376. procedure clrline(y : byte);
  377. var offset : word;
  378. begin
  379.  if pred(y)<wordrec(windmin).y then exit;
  380.  if pred(y)>wordrec(windmax).y then exit;
  381.  
  382.  offset := location(succ(wordrec(windmin).x),y);
  383.  
  384.  fillword(mem[videoseg:offset],succ(wordrec(windmax).x-wordrec(windmin).x),
  385.           byte(' ')+textattr shl 8);
  386. end;
  387.  
  388. procedure scrollup(x1,y1,x2,y2,color : byte);
  389. var loop   : word;
  390.     offset : word;
  391.     len    : word;
  392.     maxx   : word;
  393. begin
  394.  len    := x2 - pred(x1);
  395.  maxx   := maxcols*2;
  396.  offset := location(x1,succ(y1));
  397.  
  398.  for loop := y1 to pred(y2) do
  399.   begin
  400.    movetoscreen(mem[videoseg:offset],
  401.                 mem[videoseg:offset-maxx],len);
  402.    inc(offset,maxx); {bereken offset, dit is iets sneller}
  403.   end;
  404.  
  405.  {make last line empty}
  406.  fillword(mem[videoseg:offset-maxx],len,byte(' ')+color shl 8);
  407. end;
  408.  
  409. procedure scrolldown(x1,y1,x2,y2,color : byte);
  410. var loop   : word;
  411.     offset : word;
  412.     len    : word;
  413.     maxx   : word;
  414. begin
  415.  len    := x2 - pred(x1);
  416.  maxx   := maxcols*2;
  417.  offset := location(x1,y2); {bereken offset}
  418.  
  419.  for loop := pred(y2) downto y1 do
  420.   begin
  421.    movetoscreen(mem[videoseg:offset-maxx],
  422.                 mem[videoseg:offset],len);
  423.    dec(offset,maxx); {bereken offset, dit is iets sneller}
  424.   end;
  425.  {make last line empty}
  426.  
  427.  fillword(mem[videoseg:offset],len,byte(' ')+color shl 8);
  428. end;
  429.  
  430. procedure delline;
  431. var y : byte;
  432. begin
  433.  y := wherey + wordrec(windmin).y;
  434.  
  435.  scrollup(succ(wordrec(windmin).x),y,
  436.           succ(wordrec(windmax).x),succ(wordrec(windmax).y),
  437.           textattr);
  438. end;
  439.  
  440. procedure insline;
  441. var y : byte;
  442. begin
  443.  y := wherey + wordrec(windmin).y;
  444.  
  445.  scrolldown(succ(wordrec(windmin).x),y,
  446.             succ(wordrec(windmax).x),succ(wordrec(windmax).y),
  447.             textattr);
  448. end;
  449.  
  450. function windowcols : byte;
  451. begin
  452.  windowcols := succ(wordrec(windmax).x-wordrec(windmin).x);
  453. end;
  454.  
  455. function windowrows : byte;
  456. begin
  457.  windowrows := succ(wordrec(windmax).y-wordrec(windmin).y);
  458. end;
  459.  
  460. (*---- device driver for screen writes -------------------------------------*)
  461. {$F+}
  462. function crtinput(var f : textrec) : integer;
  463. label keyboard;
  464. begin
  465. keyboard:
  466.  f.bufptr^[0] := readkey;
  467.  if f.bufptr^[0] = #0 then begin
  468.                             f.bufptr^[0] := readkey;
  469.                             goto keyboard;
  470.                            end;
  471.  if f.bufptr^[0] = #8 then goto keyboard;
  472.  if f.bufptr^[0] = #13 then
  473.   begin
  474.    f.bufptr^[1] := #10;
  475.    f.bufend := 2;
  476.    writeln;
  477.   end else begin
  478.             f.bufend := 1;
  479.             write(f.bufptr^[0]);
  480.            end;
  481.  
  482.  f.bufpos := 0;
  483.  crtinput := 0;
  484. end;
  485.  
  486. function crtoutput(var f : textrec) : integer;
  487. var counter : word; {voor een loop}
  488.     ch      : byte; {charakter}
  489.     offset  : word;
  490.     x,y     : byte;
  491.  
  492.   procedure scrollwindowup;
  493.   begin
  494.    if y >= wordrec(windmax).y then
  495.     begin
  496.      if not scrolllockscreen then
  497.       scrollup(succ(wordrec(windmin).x),succ(wordrec(windmin).y),
  498.                succ(wordrec(windmax).x),succ(wordrec(windmax).y),
  499.                textattr);
  500.     end else inc(y);
  501.   end;
  502.  
  503. begin
  504.  counter := 0;
  505.  x := pred(wherex) + wordrec(windmin).x;
  506.  y := pred(wherey) + wordrec(windmin).y;
  507.  
  508.  while counter <f.bufpos do
  509.   begin
  510.    ch := byte(f.bufptr^[counter]);
  511.    case ch of
  512.     07 : ; {bell}
  513.     08 : ; {backspace}
  514.     10 : scrollwindowup;
  515.     13 : x := wordrec(windmin).x; {cr}
  516.     else begin
  517.           offset := videoofs + x*2 + y*maxcols*2;
  518.           fillword(mem[videoseg:offset],1,ch+textattr shl 8);
  519.           inc(x);
  520.           if x > wordrec(windmax).x then
  521.            begin
  522.             scrollwindowup;
  523.             x := wordrec(windmin).x;
  524.            end;
  525.          end;
  526.    end;
  527.  
  528.    inc(counter);
  529.   end;
  530.  
  531.  f.bufpos := 0;
  532.  crtoutput := 0;
  533.  
  534.  x := succ(x)-wordrec(windmin).x;
  535.  y := succ(y)-wordrec(windmin).y;
  536.  gotoxy(x,y);
  537. end;
  538.  
  539. function crtflush(var f : textrec) : integer;
  540. begin
  541.  crtflush := 0;
  542. end;
  543.  
  544. function crtopen(var f : textrec) : integer;
  545. begin
  546.  with textrec(f) do
  547.   begin
  548.  
  549.    if mode = fminput then
  550.     begin
  551.      inoutfunc := @crtinput;
  552.      flushfunc := @crtflush;
  553.     end
  554.     else
  555.     begin
  556.      mode := fmoutput;
  557.      inoutfunc := @crtflush;
  558.      flushfunc := @crtoutput;
  559.     end;
  560.  
  561.    closefunc := @crtflush;
  562.   end;
  563.  
  564.  crtopen := 0;
  565. end;
  566. {$F-}
  567.  
  568. procedure assigncrt(var f : text);
  569. begin
  570.  with textrec(f) do
  571.   begin
  572.    handle   := $ffff;
  573.    mode     := fmclosed;
  574.    bufsize  := sizeof(buffer);
  575.    bufptr   := @buffer;
  576.    openfunc := @crtopen;
  577.    name[0]  := #0;
  578.   end;
  579. end;
  580. (*------ end device driver -------------------------------------------------*)
  581.  
  582. (* other screen procedures *)
  583. procedure fastwrite(x,y,attr : byte;st : stscreen);
  584. begin
  585.  if ignorewindow then asmwrite(videoptr^,maxcols,x,y,attr,st)
  586.   else begin
  587.         st := copy(st,1,succ(wordrec(windmax).x)-pred(x)-wordrec(windmin).x);
  588.         if y+wordrec(windmin).y <= succ(wordrec(windmax).y) then
  589.         asmwrite(videoptr^,maxcols,wordrec(windmin).x+x,wordrec(windmin).y+y,
  590.                  attr,st);
  591.        end;
  592. end;
  593.  
  594. procedure fastpwrite(x,y : byte;st : stscreen);
  595. begin
  596.  if ignorewindow then asmpwrite(videoptr^,maxcols,x,y,st)
  597.   else begin
  598.         st := copy(st,1,succ(wordrec(windmax).x)-pred(x)-wordrec(windmin).x);
  599.         if y+wordrec(windmin).y <= succ(wordrec(windmax).y) then
  600.         asmpwrite(videoptr^,maxcols,wordrec(windmin).x+x,wordrec(windmin).y+y,
  601.                   st);
  602.        end;
  603. end;
  604.  
  605. procedure changeattr(x,y,attr,len : byte);
  606. begin
  607.  if ignorewindow then asmattr(videoptr^,maxcols,x,y,attr,len)
  608.   else begin
  609.         inc(x,wordrec(windmin).x);
  610.         inc(y,wordrec(windmin).y);
  611.         if (x<=succ(wordrec(windmax).x)) and (y<=succ(wordrec(windmax).y)) then
  612.          begin
  613.           if x+len > succ(wordrec(windmax).x) then
  614.           len := succ(wordrec(windmax).x) - pred(x);
  615.           asmattr(videoptr^,maxcols,x,y,attr,len)
  616.          end;
  617.        end;
  618. end;
  619.  
  620. procedure titleengine(x1,y1,x2,y2 : byte;bt : bordertypes;
  621.                       var title : stscreen);
  622. var signorewindow : boolean;
  623.     width         : integer;
  624.     optstr        : string[4];
  625.     delim         : charset;
  626.     dropbox       : boolean;
  627.     placestr      : (leftpad,rightpad,center);
  628.     xpos,ypos     : byte;
  629. begin
  630.  signorewindow := ignorewindow;
  631.  ignorewindow  := true;
  632.  delim         := ['_','^','<','>','+','|'];
  633.  ypos          := y1;
  634.  placestr      := center;
  635.  dropbox       := false;
  636.  while (length(title)>0) and (title[1] in delim) do
  637.   begin
  638.    case title[1] of
  639.     '_' : ypos     := y2;
  640.     '^' : ypos     := y1;
  641.     '<' : placestr := leftpad;
  642.     '>' : placestr := rightpad;
  643.     '+' : placestr := center;
  644.     '|' : dropbox  := true;
  645.    end; {case}
  646.    delete(title,1,1);
  647.   end;
  648.  
  649.  if dropbox then width := (x2-x1)-5
  650.   else width := (x2-x1)-3;
  651.  
  652.  if (width>1) and (title<>'') then
  653.   begin
  654.    delete(title,succ(width),255);
  655.  
  656.    case bt of
  657.     doublebrdr                : bt := horizdoublevertsinglebrdr;
  658.     horizsinglevertdoublebrdr : bt := singlebrdr;
  659.    end; {case}
  660.  
  661.    case placestr of
  662.     leftpad  : xpos := x1 + 2;
  663.     rightpad : begin
  664.                 xpos := succ(x2-length(title)) - 2;
  665.                 if dropbox then dec(xpos,2);
  666.                end;
  667.     center   : if dropbox then
  668.                 xpos := ((succ(x2-x1)-(length(title)+2)) div 2) + x1
  669.                 else xpos := ((succ(x2-x1)-length(title)) div 2) + x1;
  670.    end; {case}
  671.    if dropbox then
  672.     fastpwrite(xpos,ypos,borderst[bt,rc]+ title +borderst[bt,lc])
  673.     else fastpwrite(xpos,ypos,title)
  674.  
  675.   end;
  676.  
  677.  ignorewindow := signorewindow;
  678. end;
  679.  
  680. procedure boxengine(x1,y1,x2,y2,attr : byte;
  681.                     bordertype : bordertypes;filled : boolean);
  682. var signorewindow : boolean;
  683.     loop          : byte;
  684.  
  685.   function duplicate(ch : char;times : byte) : string;
  686.   var f : string;
  687.   begin
  688.    fillchar(f,times+1,ch);
  689.    byte(f[0]) := times;
  690.    duplicate := f;
  691.   end;
  692.  
  693. begin
  694.  signorewindow := ignorewindow;
  695.  ignorewindow  := true;
  696.  
  697.  fastwrite(x1,y1,attr,borderst[bordertype,tl] +
  698.                       duplicate(borderst[bordertype,ht],pred(x2-x1)) +
  699.                       borderst[bordertype,tr]);
  700.  
  701.  if filled then
  702.   for loop := succ(y1) to pred(y2) do
  703.    begin
  704.     fastwrite(x1,loop,attr,borderst[bordertype,vl]+duplicate(' ',pred(x2-x1))+
  705.                            borderst[bordertype,vr]);
  706.    end
  707.   else for loop := succ(y1) to pred(y2) do
  708.         begin
  709.          fastwrite(x1,loop,attr,borderst[bordertype,vl]);
  710.          fastwrite(x2,loop,attr,borderst[bordertype,vr]);
  711.         end;
  712.  
  713.  fastwrite(x1,y2,attr,borderst[bordertype,bl] +
  714.                       duplicate(borderst[bordertype,hb],pred(x2-x1)) +
  715.                       borderst[bordertype,br]);
  716.  
  717.  ignorewindow := signorewindow;
  718. end;
  719.  
  720.  
  721. (* cursor mapipulation *)
  722. procedure normalcursor;
  723. var size : word;
  724. begin
  725.  if basescreen=$b800 then size := $0607
  726.   else size := $0b0c;
  727.  setcursorshape(size);
  728. end;
  729.  
  730. procedure insertcursor;
  731. var size : word;
  732. begin
  733.  if basescreen=$b800 then size := $0507
  734.   else size := $090c;
  735.  setcursorshape(size);
  736. end;
  737.  
  738. procedure halfcursor;
  739. var size : word;
  740. begin
  741.  if basescreen=$b800 then size := $0407
  742.   else size := $070d;
  743.  setcursorshape(size);
  744. end;
  745.  
  746. procedure hidecursor;
  747. begin
  748.  setcursorshape($2000);
  749. end;
  750.  
  751.  
  752. (* quickwindow procedures *)
  753. function calcsizescreen(x1,y1,x2,y2 : byte) : word;
  754. begin
  755.  calcsizescreen := ((x2-(x1-1))*(y2-(y1-1)))*2 + 6;
  756. end;
  757.  
  758. function savepartscreen(x1,y1,x2,y2 : byte) : savescrptr;
  759. var tempscrptr : savescrptr;
  760.     loop,
  761.     count,
  762.     tempsize,
  763.     lenline,
  764.     offset     : word;
  765. begin
  766.  tempsize := calcsizescreen(x1,y1,x2,y2);
  767.  if tempsize>maxavail then
  768.   begin
  769.    savepartscreen := nil;
  770.    exit;
  771.   end;
  772.  
  773.  getmem(tempscrptr,tempsize);
  774.  dec(x1);
  775.  with tempscrptr^ do
  776.   begin
  777.    screensize := tempsize;
  778.    count      := 1;
  779.    lenline    := x2-x1;
  780.    for loop := y1 to y2 do
  781.     begin
  782.      offset := videoofs + (x1*2) + (maxcols*2*(loop-1));
  783.      movefromscreen(mem[videoseg:offset],savedscr[count],lenline);
  784.      inc(count,lenline);
  785.     end;
  786.   end;
  787.  savepartscreen := tempscrptr;
  788. end;
  789.  
  790. procedure restorepartscreen(var scrptr : savescrptr;x1,y1,x2,y2 : byte);
  791. var loop     : byte;
  792.     lenline,
  793.     count,
  794.     offset   : word;
  795. begin
  796.  if scrptr=nil then exit;
  797.  dec(x1);
  798.  
  799.  with scrptr^ do
  800.   begin
  801.    count   := 1;
  802.    lenline := x2-x1;
  803.    for loop := y1 to y2 do
  804.     begin
  805.      offset := videoofs + (x1*2)+(maxcols*2*(loop-1));
  806.      movetoscreen(savedscr[count],mem[videoseg:offset],lenline);
  807.      count := count + lenline; {*2 voor attr}
  808.     end;
  809.   end;
  810. end;
  811.  
  812. procedure disposepartscreen(var scrptr : savescrptr);
  813. begin
  814.  if scrptr=nil then exit;
  815.  
  816.  freemem(scrptr,scrptr^.screensize);
  817.  scrptr := nil;
  818. end;
  819.  
  820. procedure quickopenwindow(x1,y1,x2,y2,attr : byte;bt : bordertypes;
  821.                           st : stscreen);
  822. var tempquickwindow : quickwindowptr;
  823. begin
  824.  if x1>x2 then exit;
  825.  if y1>y2 then exit;
  826.  if maxavail<sizeof(quickwindowrec)+calcsizescreen(x1,y1,x2,y2) then exit;
  827.  
  828.  new(tempquickwindow); { reserve memory }
  829.  tempquickwindow^.x1 := x1;
  830.  tempquickwindow^.y1 := y1;
  831.  tempquickwindow^.x2 := x2;
  832.  tempquickwindow^.y2 := y2;
  833.  tempquickwindow^.bt := bt;
  834.  
  835.  with tempquickwindow^ do
  836.   begin
  837.    previous      := nil;
  838.    windowinfo    := savepartscreen(x1,y1,x2,y2);
  839.  
  840.    stextattr     := textattr;
  841.    textattr      := attr;
  842.    sscrolllock   := scrolllockscreen;
  843.    signorewindow := ignorewindow;
  844.    sscanlines    := getcursorshape;
  845.    sx            := wherex;
  846.    sy            := wherey;
  847.    swindmin      := windmin;
  848.    swindmax      := windmax;
  849.  
  850.    boxengine(x1,y1,x2,y2,textattr,bt,true);
  851.    if bt=nobrdr then window(x1,y1,x2,y2)
  852.     else begin
  853.           titleengine(x1,y1,x2,y2,bt,st);
  854.           window(succ(x1),succ(y1),pred(x2),pred(y2));
  855.          end;
  856.  
  857.    normalcursor;
  858.   end;
  859.  
  860.  
  861.  if visiblequickwindow=nil then visiblequickwindow := tempquickwindow
  862.   else begin
  863.         tempquickwindow^.previous := visiblequickwindow;
  864.         visiblequickwindow := tempquickwindow
  865.        end;
  866.  
  867. { set defaults }
  868.  scrolllockscreen := false; {scroll screen}
  869.  ignorewindow       := false;
  870. end;
  871.  
  872. procedure quickmovewindow(x,y : byte);
  873. var trows,
  874.     tcols,
  875.     srow,
  876.     scol,
  877.     loop     : byte;
  878.     lenline,
  879.     count,
  880.     offset   : word;
  881. begin
  882.  with visiblequickwindow^ do
  883.   begin
  884.   { check if it wil fit on screen }
  885.    tcols := x2-x1;
  886.    trows := y2-y1;
  887.    if tcols+x>maxcols then exit;
  888.    if trows+y>maxrows then exit;
  889.    with windowinfo^ do
  890.     begin
  891.     { first underlying restore screen }
  892.      count   := 1;
  893.      lenline := x2-pred(x1);
  894.      for loop := y1 to y2 do
  895.       begin
  896.        offset := videoofs + (pred(x1)*2)+(maxcols*2*(loop-1));
  897.        swapvar(savedscr[count],mem[videoseg:offset],lenline*2);
  898.        count := count + lenline; {*2 voor attr}
  899.       end;
  900.     { restore window on new place }
  901.      x1   := x;
  902.      y1   := y;
  903.      x2   := x1+tcols;
  904.      y2   := y1+trows;
  905.      scol := wherex;
  906.      srow := wherey;
  907.      if bt=nobrdr then window(x1,y1,x2,y2)
  908.       else window(succ(x1),succ(y1),pred(x2),pred(y2));
  909.      gotoxy(scol,srow);
  910.      count   := 1;
  911.      lenline := x2-pred(x1);
  912.      for loop := y1 to y2 do
  913.       begin
  914.        offset := videoofs + (pred(x1)*2)+(maxcols*2*(loop-1));
  915.        swapvar(savedscr[count],mem[videoseg:offset],lenline*2);
  916.        count := count + lenline; {*2 voor attr}
  917.       end;
  918.     end;
  919.   end;
  920. end;
  921.  
  922. procedure quickclosewindow;
  923. var tempquickwindow : quickwindowptr;
  924. begin
  925.  if visiblequickwindow=nil then exit;
  926.  
  927.  tempquickwindow := visiblequickwindow;
  928.  
  929.  with tempquickwindow^ do
  930.   begin
  931.    restorepartscreen(windowinfo,x1,y1,x2,y2);
  932.    textattr         := stextattr;
  933.    scrolllockscreen := sscrolllock;
  934.    ignorewindow     := signorewindow;
  935.    setcursorshape(sscanlines);
  936.    windmin          := swindmin;
  937.    windmax          := swindmax;
  938.    gotoxy(sx,sy);
  939.    disposepartscreen(windowinfo);
  940.    visiblequickwindow := visiblequickwindow^.previous;
  941.   end;
  942.  
  943.  dispose(tempquickwindow);
  944. end;
  945.  
  946. (* crt exit handler *)
  947.  
  948. {$F+}
  949. procedure exityncrt;
  950. var m : byte;
  951. begin
  952.  exitproc := orginalexitproc;
  953.  
  954.  close(output); {hoeft eigenlijk niet}
  955.  close(input);  {hoeft eigenlijk niet}
  956.  
  957.  setcursorshape(startupcursorsize);
  958. (* return to orginal text mode *)
  959.  
  960.  if (startupmode<>lastmode) then textmode(startupmode);
  961. end;
  962. {$F-}
  963.  
  964.  
  965.  
  966. begin
  967.   orginalexitproc := exitproc;
  968.   exitproc        := @exityncrt;
  969.  
  970.   delayinit; {get one microsecond resolution}
  971.  
  972.   scrolllockscreen := false; {scroll screen}
  973.   getstartupcolor; {sets textattr by reading attr from screen}
  974.   wordrec(windmin).x := 0;
  975.   wordrec(windmin).y := 0; { window to entire scr }
  976.   wordrec(windmax).x := pred(maxcols);
  977.   wordrec(windmax).y := pred(maxrows);
  978.   ignorewindow       := false;
  979.   (* initialeren van textdevice driver *)
  980.   assigncrt(output); rewrite(output);
  981.   assigncrt(input);  reset(input);
  982.  
  983.   visiblequickwindow := nil;
  984. end.
  985.