home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1991 / 06 / telscope.asc < prev    next >
Text File  |  1991-05-02  |  40KB  |  1,289 lines
  1. _CELESTIAL PROGRAMMING WITH TURBO PASCAL_
  2. by Lars Frid-Neilson and Alex Lane
  3.  
  4.  
  5. [LISTING ONE]
  6.  
  7. unit Video;
  8. {*******************************************************}
  9. interface
  10. {*******************************************************}
  11.  
  12. { Global constants                                      }
  13. CONST
  14.  
  15. {--- defaults for Supervision card setup                }
  16.  Aport    = $2F0;               { first port on the card }
  17.  Bport    = $2F1;              { second port on the card }
  18.  
  19. {--- field control bytes                 }
  20.  fieldsync = $40;               { new field!            }
  21.  linesync  = $41;               { new line              }
  22.  fldend    = $42;               { end of field          }
  23.  rep1      = $80;               { repeat x1             }
  24.  rep16     = $90;               { repeat x16            }
  25.  
  26. {--- image structure                                    }
  27.  maxbit    = $3F;               { bits used in pel      }
  28.  maxpel    = 255;               { highest pel index     }
  29.  maxline   = 252;               { highest line index    }
  30.  maxbuffer = 32766;             { highest "INT" index   }
  31.  
  32. { Global types                                          }
  33.  
  34. TYPE
  35.  bitrng    = 0..maxbit;         { bit range             }
  36.  pelrng    = 0..maxpel;         { pel indexes           }
  37.  framerng  = 0..maxline;        { line indexes          }
  38.  subrng    = 0..maxbuffer;      { raw data indexes      }
  39.  pelrec    = RECORD             { one scan line         }
  40.            syncL : BYTE;
  41.            pels  : ARRAY[pelrng] OF BYTE;
  42.            END;
  43.  framerec  = RECORD             { complete binary field }
  44.            syncF : BYTE;
  45.            lines : ARRAY[framerng] OF pelrec;
  46.            syncE : BYTE;
  47.            END;
  48.  rawrec    = ARRAY[subrng] OF INTEGER;
  49.  picptr    = ^pictype;                 { picture ptr    }
  50.  pictype   = RECORD CASE INTEGER OF    { picture formats}
  51.            0 : (fmt : framerec);
  52.            1 : (words : rawrec);
  53.            END;
  54.  histtype  = ARRAY[bitrng] OF Word;    { pel histograms }
  55.  regrec = RECORD CASE INTEGER OF
  56.           1 : (AX : INTEGER;
  57.                BX : INTEGER;
  58.                CX : INTEGER;
  59.                DX : INTEGER;
  60.                BP : INTEGER;
  61.                SI : INTEGER;
  62.                DI : INTEGER;
  63.                DS : INTEGER;
  64.                ES : INTEGER;
  65.                FLAGS : INTEGER);
  66.           2 : (AL,AH : BYTE;
  67.                BL,BH : BYTE;
  68.                CL,CH : BYTE;
  69.                DL,DH : BYTE);
  70.          END;
  71.  byteptr   = ^BYTE;                    { general ptr    }
  72.  strtype   = STRING[255];              { strings        }
  73.  Hextype   = STRING[4];
  74.  
  75. { Global functions and procedures            }
  76.  
  77. PROCEDURE Add(pic1,pic2 : picptr);
  78. PROCEDURE Subtract(pic1,pic2 : picptr);
  79. PROCEDURE Mask(pic1,pic2 : picptr);
  80. PROCEDURE Compare(pic1,pic2 : picptr);
  81. PROCEDURE Offset(pic1 : picptr; newoffs : BYTE);
  82. PROCEDURE Negoffset(pic1 : picptr; newoffs : BYTE);
  83. PROCEDURE Multiply(pic1 : picptr; newscale : REAL);
  84. PROCEDURE Threshold(pic1 : picptr; level : BYTE);
  85. PROCEDURE Invert(pic1 : picptr);
  86. PROCEDURE Filter1(pic1,pic2 : picptr);
  87. PROCEDURE Edge(pic1,pic2 : picptr);
  88. PROCEDURE Histogram(pic1 :picptr; VAR histo : histtype);
  89. PROCEDURE PicSetup(VAR newpic : picptr);
  90.  
  91. function SavePicture(filespec : strtype; pic : picptr): integer;
  92. function LoadPicture(filespec : strtype; pic : picptr): integer;
  93.  
  94. PROCEDURE SetSyncs(pic1 : picptr);
  95. PROCEDURE Card;
  96.  
  97. function Capture: BOOLEAN;
  98.  
  99. PROCEDURE Scan(pic1 : picptr);
  100.  
  101. {*******************************************************}
  102. implementation
  103. {*******************************************************}
  104.  
  105. { Do pic1 + pic2 into pic3                              }
  106. { Sticks at maxbit                                      }
  107.  
  108. PROCEDURE Add(pic1,pic2 : picptr);
  109. VAR
  110.  lndx      : framerng;          { line number           }
  111.  pndx      : pelrng;            { pel number            }
  112.  pelval    : INTEGER;           { pel value             }
  113.  
  114. BEGIN
  115.  FOR lndx := 0 TO maxline DO
  116.   FOR pndx := 0 TO maxpel DO BEGIN
  117.    pelval := pic1^.fmt.lines[lndx].pels[pndx] +
  118.               pic2^.fmt.lines[lndx].pels[pndx];
  119.    IF pelval > maxbit THEN 
  120.      pic1^.fmt.lines[lndx].pels[pndx] := maxbit
  121.    ELSE
  122.      pic1^.fmt.lines[lndx].pels[pndx] := pelval;
  123.   END;
  124. END;
  125.  
  126. { Do pic1 - pic2 into pic3                              }
  127. { Sticks at zero for pic1 < pic2                        }
  128.  
  129. PROCEDURE Subtract(pic1,pic2 : picptr);
  130. VAR
  131.  lndx      : framerng;          { line number           }
  132.  pndx      : pelrng;            { pel number            }
  133.  
  134. BEGIN
  135.  FOR lndx := 0 TO maxline DO
  136.   FOR pndx := 0 TO maxpel DO
  137.    IF pic1^.fmt.lines[lndx].pels[pndx] >=
  138.       pic2^.fmt.lines[lndx].pels[pndx]
  139.     THEN 
  140.       pic1^.fmt.lines[lndx].pels[pndx] :=
  141.                    pic1^.fmt.lines[lndx].pels[pndx] -
  142.                    pic2^.fmt.lines[lndx].pels[pndx]
  143.     ELSE 
  144.       pic1^.fmt.lines[lndx].pels[pndx] := 0;
  145.  
  146. END;
  147.  
  148. { Do pic1 masked by pic2 into pic3                      }
  149. { Only pic1 pels at non-zero pic2 pels go to pic3       }
  150.  
  151. PROCEDURE Mask(pic1,pic2 : picptr);
  152. VAR
  153.  lndx      : framerng;          { line number           }
  154.  pndx      : pelrng;            { pel number            }
  155.  
  156. BEGIN
  157.  FOR lndx := 0 TO maxline DO
  158.   FOR pndx := 0 TO maxpel DO
  159.    IF pic2^.fmt.lines[lndx].pels[pndx] = 0 then
  160.      pic1^.fmt.lines[lndx].pels[pndx] := 0;
  161. END;
  162.  
  163. { Do Abs(pic1 - pic2) into pic3                         }
  164. { Detects changes in images                             }
  165.  
  166. PROCEDURE Compare(pic1,pic2: picptr);
  167. VAR
  168.  lndx      : framerng;          { line number           }
  169.  pndx      : pelrng;            { pel number            }
  170.  
  171. BEGIN
  172.  FOR lndx := 0 TO maxline DO
  173.   FOR pndx := 0 TO maxpel DO
  174.     pic1^.fmt.lines[lndx].pels[pndx] := Abs(
  175.                    pic1^.fmt.lines[lndx].pels[pndx] -
  176.                    pic2^.fmt.lines[lndx].pels[pndx]);
  177.  
  178. END;
  179.  
  180. { Add a constant to pic1                                }
  181.  
  182. PROCEDURE Offset(pic1 : picptr;
  183.                  newoffs : BYTE);
  184. VAR
  185.  lndx      : framerng;          { line number           }
  186.  pndx      : pelrng;            { pel number            }
  187.  pelval    : INTEGER;           { pel value             }
  188.  
  189. BEGIN
  190.   FOR lndx := 0 TO maxline DO
  191.     FOR pndx := 0 TO maxpel DO BEGIN
  192.       pelval := newoffs + pic1^.fmt.lines[lndx].pels[pndx];
  193.       IF (pelval AND $FFC0) = 0 THEN
  194.         pic1^.fmt.lines[lndx].pels[pndx] := pelval
  195.       ELSE
  196.         pic1^.fmt.lines[lndx].pels[pndx] := maxbit;
  197.     END;
  198. END;
  199.  
  200. { subtract a value from a picture            }
  201.  
  202. PROCEDURE Negoffset(pic1 : picptr;
  203.                  newoffs : BYTE);
  204. VAR
  205.  lndx      : framerng;          { line number           }
  206.  pndx      : pelrng;            { pel number            }
  207.  pelval    : INTEGER;           { pel value             }
  208.  
  209. BEGIN
  210.  FOR lndx := 0 TO maxline DO
  211.    FOR pndx := 0 TO maxpel DO BEGIN
  212.      pelval := pic1^.fmt.lines[lndx].pels[pndx] - newoffs;
  213.      IF (pelval AND $FFC0) = 0 THEN
  214.        pic1^.fmt.lines[lndx].pels[pndx] := pelval
  215.      ELSE
  216.        pic1^.fmt.lines[lndx].pels[pndx] := maxbit;
  217.    END;
  218. END;
  219.  
  220. { Multiply pic1 by a value                              }
  221. { Sticks at maximum value                               }
  222.  
  223. PROCEDURE Multiply(pic1 : picptr; newscale : REAL);
  224. VAR
  225.  lndx      : framerng;          { line number           }
  226.  pndx      : pelrng;            { pel number            }
  227.  pelval    : INTEGER;           { pel value             }
  228.  
  229. BEGIN
  230.  FOR lndx := 0 TO maxline DO
  231.   FOR pndx := 0 TO maxpel DO BEGIN
  232.    pelval := Trunc(newscale * pic1^.fmt.lines[lndx].pels[pndx]);
  233.    IF (pelval AND $FFC0) = 0 THEN
  234.      pic1^.fmt.lines[lndx].pels[pndx] := pelval
  235.    ELSE
  236.      pic1^.fmt.lines[lndx].pels[pndx] := maxbit;
  237.   END;
  238. END;
  239.  
  240. { Threshold pic1 at a brightness level                  }
  241.  
  242. PROCEDURE Threshold(pic1 : picptr;
  243.                     level : BYTE);
  244. VAR
  245.  lndx      : framerng;          { line number           }
  246.  pndx      : pelrng;            { pel number            }
  247.  
  248. BEGIN
  249.  FOR lndx := 0 TO maxline DO
  250.   FOR pndx := 0 TO maxpel DO
  251.    IF pic1^.fmt.lines[lndx].pels[pndx]  < level
  252.     THEN pic1^.fmt.lines[lndx].pels[pndx] := 0;
  253. END;
  254.  
  255. { Invert pel values                                     }
  256.  
  257. PROCEDURE Invert(pic1 : picptr);
  258. VAR
  259.  lndx      : framerng;          { line number           }
  260.  pndx      : pelrng;            { pel number            }
  261.  
  262. BEGIN
  263.  FOR lndx := 0 TO maxline DO
  264.   FOR pndx := 0 TO maxpel DO
  265.    pic1^.fmt.lines[lndx].pels[pndx]  := maxbit AND
  266.       (NOT pic1^.fmt.lines[lndx].pels[pndx]);
  267. END;
  268.  
  269. { Filter by averaging vertical and horizontal neighbors }
  270.  
  271. PROCEDURE Filter1(pic1,pic2 : picptr);
  272. VAR
  273.  lndx      : framerng;          { line number           }
  274.  pndx      : pelrng;            { pel number            }
  275.  
  276. BEGIN
  277.  FOR lndx := 1 TO (maxline-1) DO
  278.   FOR pndx := 1 TO (maxpel-1) DO
  279.    pic2^.fmt.lines[lndx].pels[pndx] :=
  280.       (pic1^.fmt.lines[lndx-1].pels[pndx] +
  281.        pic1^.fmt.lines[lndx+1].pels[pndx] +
  282.        pic1^.fmt.lines[lndx].pels[pndx-1] +
  283.        pic1^.fmt.lines[lndx].pels[pndx+1])
  284.       SHR 2;
  285. END;
  286.  
  287. { Edge detection                                        }
  288.  
  289. PROCEDURE Edge(pic1,pic2 : picptr);
  290. VAR
  291.  lndx      : framerng;          { line number           }
  292.  pndx      : pelrng;            { pel number            }
  293.  
  294. BEGIN
  295.  FOR lndx := 1 TO (maxline-1) DO
  296.   FOR pndx := 1 TO (maxpel-1) DO
  297.    pic2^.fmt.lines[lndx].pels[pndx] :=
  298.       (Abs(pic1^.fmt.lines[lndx-1].pels[pndx] -
  299.            pic1^.fmt.lines[lndx+1].pels[pndx]) +
  300.        Abs(pic1^.fmt.lines[lndx].pels[pndx-1] -
  301.            pic1^.fmt.lines[lndx].pels[pndx+1]) +
  302.        Abs(pic1^.fmt.lines[lndx-1].pels[pndx-1] -
  303.            pic1^.fmt.lines[lndx+1].pels[pndx+1]) +
  304.        Abs(pic1^.fmt.lines[lndx+1].pels[pndx-1] -
  305.            pic1^.fmt.lines[lndx-1].pels[pndx+1]))
  306.       SHR 2;
  307. END;
  308.  
  309. { Compute intensity histogram for pic1                  }
  310.  
  311. PROCEDURE Histogram(pic1 :picptr;
  312.            VAR histo : histtype);
  313. VAR
  314.  hndx      : bitrng;            { histogram bin number  }
  315.  lndx      : framerng;          { line number           }
  316.  pndx      : pelrng;            { pel number            }
  317.  
  318. BEGIN
  319.  FOR hndx := 0 TO maxbit DO     { reset histogram       }
  320.   histo[hndx] := 0;
  321.  FOR lndx := 0 TO maxline DO
  322.   FOR pndx := 0 TO maxpel DO
  323.    histo[pic1^.fmt.lines[lndx].pels[pndx]] :=
  324.      histo[pic1^.fmt.lines[lndx].pels[pndx]] + 1;
  325. END;
  326.  
  327. { Allocate and initialize the picture buffer            }
  328.  
  329. PROCEDURE PicSetup(VAR newpic : picptr);
  330. VAR
  331.  pels      : pelrng;
  332.  lines     : framerng;
  333.  
  334. BEGIN
  335.  IF newpic <> NIL               { discard if allocated  }
  336.   THEN Dispose(newpic);
  337.  New(newpic);                   { allocate new array    }
  338. END;
  339.  
  340. { Save picture file on disk                             }
  341. { Uses the smallest number of blocks to fit the data    }
  342.  
  343. function SavePicture(filespec : strtype; pic : picptr): integer;
  344. VAR
  345.  ndx       : subrng;            { index into word array }
  346.  rndx      : REAL;              { real equivalent       }
  347.  nblocks   : INTEGER;           { number of disk blocks }
  348.  xfered    : INTEGER;           { number actually done  }
  349.  pfile     : FILE;              { untyped file for I/O  }
  350.  RtnCode   : integer;
  351.  
  352. BEGIN
  353.   RtnCode := 0;
  354.  Assign(pfile,filespec);
  355.  Rewrite(pfile);
  356.  ndx := 0;                      { start with first word }
  357.  WHILE (ndx < maxbuffer) AND    { WHILE not end of pic  }
  358.        (Lo(pic^.words[ndx]) <> fldend) AND
  359.        (Hi(pic^.words[ndx]) <> fldend) DO
  360.    ndx := ndx + 1;
  361.  
  362.  ndx := ndx + 1;                { fix 0 origin          }
  363.  
  364.  rndx := 2.0 * ndx;             { allow >32K numbers... }
  365.  nblocks := ndx DIV 64;         { 64 words = 128 bytes  }
  366.  IF (ndx MOD 64) <> 0           { partial block?        }
  367.   THEN nblocks := nblocks + 1;
  368.  rndx := 128.0 * nblocks;       { actual file size      }
  369.  BlockWrite(pfile,pic^.words[0],nblocks,xfered);
  370.  
  371.  IF xfered <> nblocks then RtnCode := IOresult;
  372.  SavePicture := IOresult;
  373.  Close(pfile);
  374. END;
  375.  
  376. { Load picture file from disk                           }
  377.  
  378. function LoadPicture(filespec : strtype;
  379.                       pic : picptr): integer;
  380. var
  381.   picfile   : FILE OF pictype;
  382.   RtnCode   : integer;
  383.  
  384. BEGIN
  385.  Assign(picfile,filespec);
  386.  {$I- turn off I/O checking                             }
  387.  Reset(picfile);
  388.  RtnCode := IOresult;
  389.  {$I+ turn on  I/O checking again                       }
  390.  IF RtnCode = 0 then
  391.  begin
  392. {$I- turn off I/O checking                             }
  393.    Read(picfile,pic^);            { this does the read    }
  394.    RtnCode := IOresult;
  395. {$I+ turn on  I/O checking again                       }
  396.  
  397. {  IF NOT (IOresult IN [0,$99]) then
  398.      RtnCode := -1;}
  399.    RtnCode := 0;
  400.  end;
  401.  LoadPicture := RtnCode;
  402. end;
  403.  
  404. { Set up frame and line syncs in a buffer               }
  405. { This should be done only in freshly allocated buffers }
  406.  
  407. PROCEDURE SetSyncs(pic1 : picptr);
  408. VAR
  409.  lndx      : framerng;          { index into lines      }
  410.  
  411. BEGIN
  412.  pic1^.fmt.syncF := fieldsync;  { set up empty picture  }
  413.  
  414.  FOR lndx := 0 TO maxline DO BEGIN
  415.   pic1^.fmt.lines[lndx].syncL := linesync;
  416.   FillChar(pic1^.fmt.lines[lndx].pels[0],maxpel+1,0);
  417.  END;
  418.  pic1^.fmt.syncE := fldend;     { set ending control    }
  419. END;
  420.  
  421. { Test for the Supervisor card                }
  422. PROCEDURE Card;
  423. var test: byte;
  424.  
  425. Begin
  426. writeln ('testing for vgrab card');
  427.  Port[Bport] := 0;           { reset the output lines }
  428.  Port[Aport] := 0;
  429.  test := Port[Aport];          { look for the card    }
  430.  if (test and $0C0) = 0 then Begin
  431.      Port[Aport] := $03;
  432.      test := Port[Aport];
  433.      if (test and $0C0) <> $0C0  then
  434.      writeln ('No Supervision card found');
  435.      end;  
  436.    Port[Bport] := 0;        { reset the address lines} 
  437. end; 
  438.  
  439. { Capture routine for the Supervisor card        }
  440. function Capture: BOOLEAN;
  441. var
  442.   TimeOut : integer;
  443. Begin
  444.   Port[Bport] := 0;        { reset everything    }
  445.  
  446.   Port[Aport] := $03;        { start the capture    }
  447.   TimeOut := 15000;
  448.   while ((Port[Aport] and $0C0) = $0C0) and (TimeOut > 0)  do
  449.    TimeOut := pred(TimeOut);
  450.  
  451.   Port[Bport] := 0;        { reset everything    }
  452.   Capture := TimeOut <> 0;
  453. end;
  454.   
  455. { Scan data routine for the Supervisor card        }
  456. PROCEDURE Scan(pic1 : picptr);
  457.  
  458. (*
  459. VAR
  460.  lndx      : framerng;          { line number           }
  461.  pndx      : pelrng;            { pel number            }
  462. *)
  463.  
  464. BEGIN
  465.  
  466. (* This is the original pascal code:
  467.    =================================
  468.  
  469.  Port[Bport] := 0;        { reset everything    }
  470.  FOR lndx := 0 TO maxline DO
  471.   FOR pndx := 0 TO maxpel DO Begin
  472.    pic1^.fmt.lines[lndx].pels[pndx] 
  473.     := (Port[Aport] and $3F);
  474.    Port[Aport] := $02;        { next address        } 
  475.    Port[Aport] := 0;        { idle the lines    }
  476.   end; 
  477.  
  478.   Port[Bport] := 0;        { reset everything    }
  479.  
  480.   Now replaced by the following assembler code:
  481.   =============================================    *)
  482.  
  483.   asm
  484.             mov dx,2F1H
  485.             xor al,al
  486.             out dx,al
  487.             mov bx,maxline
  488.             les di,pic1
  489.             inc di            (* skip syncF byte *)
  490.             cld
  491.             mov dx,2F0H
  492. @ReadBoard: mov cx,maxpel+1
  493.             inc di            (* skip syncL *)
  494. @ReadLine:  in  al,dx
  495.             and al,3FH
  496.             stosb
  497.             mov  al,2
  498.             out  dx,al
  499.             xor  al,al
  500.             out  dx,al
  501.             loop @ReadLine
  502.             dec  bx
  503.             jnz  @ReadBoard
  504.             mov dx,2F1H
  505.             xor al,al
  506.             out dx,al
  507.   end
  508. end;
  509.  
  510. {*******************************************************}
  511.  
  512. end.
  513.  
  514.  
  515.  
  516. [LISTING TWO
  517.  
  518. {$X+,S-}
  519. {$M 16384,8192,655360}
  520. uses
  521.   Crt, Dos, Objects, Drivers, Memory, Views, Menus,
  522.   StdDlg, MsgBox, App, Video, Vga, Dialogs;
  523.  
  524. const
  525.   cmFOpen         = 1000;
  526.   cmFSave         = 1001;
  527.   cmFSaveAs       = 1002;
  528.   cmExpMon        = 2000;
  529.   cmExpInteg      = 2001;
  530.   cmExpGrab       = 2002;
  531.   cmMrgCompare    = 3000;
  532.   cmMrgAdd        = 3001;
  533.   cmMrgSub        = 3002;
  534.   cmMrgMask       = 3003;
  535.   cmProEdge       = 4000;
  536.   cmProFilter     = 4001;
  537.   cmProHist       = 4002;
  538.   cmProMult       = 4003;
  539.   cmProInvert     = 4004;
  540.   cmProOffset     = 4005;
  541.   cmProThreshold  = 4006;
  542.   cmDisplay       = 5000;
  543.   cmOptVga        = 6000;
  544.   cmOptAutoD      = 6001;
  545.   cmOptPhotoS     = 6002;
  546.  
  547.   VgaHiResTxt   : TMenuStr  ='~V~GA HiRes          ';
  548.   AutoDisplayTxt: TMenuStr  ='~A~uto Display       ';
  549.   PhotoModeTxt  :TMenuStr   ='~P~hoto session      ';
  550.   OnTxt         : string[4] =' On';
  551.   OffTxt        : string[4] ='Off';
  552.  
  553. type
  554.   pHistoView  = ^HistoView;
  555.   HistoView = object(TView)
  556.     histo     : histtype;
  557.     constructor Init(Bounds: TRect);
  558.     procedure   Draw; virtual;
  559.     procedure Update(Picture : picptr);
  560.   end;
  561.  
  562.   pHistoWindow = ^HistoWindow;
  563.  
  564.   HistoWindow  = object(TWindow)
  565.    HistoView:  pHistoView;
  566.    constructor Init;
  567.   end;
  568.  
  569.   pCCDpgm = ^CCDpgm;
  570.   CCDpgm  = object(TApplication)
  571.     CurPicture:   PicPtr;
  572.     CurFileName:  PathStr;
  573.     PictureDirty: boolean;
  574.     HistoGram:    pHistoWindow;
  575.     procedure FileOpen(WildCard: PathStr);
  576.     procedure FileSave;
  577.     procedure FileSaveAs(WildCard: PathStr);
  578.     procedure DisplayImage;
  579.     procedure InitMenuBar; virtual;
  580.     procedure HandleEvent(var Event: TEvent); virtual;
  581.     procedure InitStatusLine; virtual;
  582.     procedure SetMenuItem(Item: string; Value: boolean);
  583.     procedure UpdateHistoGram;
  584.   end;
  585.  
  586. var
  587.   CCD: CCDpgm;
  588.  
  589. procedure GraphicsStart;
  590. begin
  591.   DoneSysError;
  592.   DoneEvents;
  593.   DoneVideo;
  594.   DoneMemory;
  595. end;
  596.  
  597. procedure GraphicsStop;
  598. begin
  599.   InitMemory;
  600.   TextMode(3);
  601.   InitVideo;
  602.   InitEvents;
  603.   InitSysError;
  604.   Application^.Redraw;
  605. end;
  606.  
  607. function TypeInDialog(var S: PathStr; Title:string):boolean;
  608. var
  609.   D: PDialog;
  610.   Control: PView;
  611.   R: TRect;
  612.   Result:Word;
  613. begin
  614.   R.Assign(0, 0, 30, 7);
  615.   D := New(PDialog, Init(R, Title));
  616.   with D^ do
  617.   begin
  618.     Options := Options or ofCentered;
  619.     R.Assign(5, 2, 25, 3);
  620.     Control := New(PInputLine, Init(R, sizeof(PathStr)-1));
  621.     Insert(Control);
  622.     R.Assign(3, 4, 15, 6);
  623.     Insert(New(PButton, Init(R, 'O~K~', cmOk, bfDefault)));
  624.     Inc(R.A.X, 12); Inc(R.B.X, 12);
  625.     Insert(New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)));
  626.     SelectNext(False);
  627.   end;
  628.   D := PDialog(Application^.ValidView(D));
  629.   if D <> nil then
  630.   begin
  631.     Result := DeskTop^.ExecView(D);
  632.     if (Result <> cmCancel) then D^.GetData(S);
  633.     Dispose(D, Done);
  634.   end;
  635.   TypeInDialog := Result <> cmCancel;
  636. end;
  637.  
  638. constructor HistoWindow.Init;
  639. var
  640.   R:TRect;
  641. begin
  642.   R.Assign(0, 0, 68,21);
  643.   TWindow.Init(R, 'Histogram', 0);
  644.   Palette := wpCyanWindow;
  645.   GetExtent(R);
  646.   Flags := Flags and not (wfZoom + wfGrow);    { Not resizeable }
  647.   GrowMode := 0;
  648.   R.Grow(-1, -1);
  649.   HistoView := New(pHistoView, Init(R));
  650.   Insert(HistoView);
  651. end;
  652.  
  653. constructor HistoView.Init(Bounds: TRect);
  654. begin
  655.   TView.Init(Bounds);
  656.   Update(CCD.CurPicture);
  657. end;
  658.  
  659. procedure HistoView.Update(Picture : picptr);
  660. begin
  661.   Histogram(Picture,histo);
  662.   DrawView;
  663. end;
  664.  
  665. procedure HistoView.Draw;
  666. const
  667.  barchar   = $DB;               { display char for bar  }
  668.  halfbar   = $DC;               { half length bar       }
  669.  maxbar    = 16;                { length of longest bar }
  670.  
  671. var
  672.  x,y       : Integer;
  673.  binID     : Integer;
  674.  maxval    : Word;              { the largest bin value }
  675.  maxval1   : Word;              { the next largest bin  }
  676.  barbase   : Word;              { bottom of bar         }
  677.  barmid    : Word;              { middle of bar         }
  678.  barstep   : Word;              { height of steps       }
  679.  halfstep  : Word;              { half of barstep       }
  680.  barctr    : Integer;           { character within bar  }
  681.  
  682. begin
  683.   TView.Draw;
  684.  maxval := 1;                 { find largest value    }
  685.  maxval1 := maxval;
  686.  binID := 0;
  687.  for binID := 0 to maxbit do
  688.  begin
  689.    if histo[binID] > maxval then
  690.    begin   { new all-time high?    }
  691.      maxval1 := maxval;          { save previous high    }
  692.      maxval := histo[binID]; { set new high          }
  693.    end
  694.    else if histo[binID] > maxval1  then { 2nd highest?   }
  695.      maxval1 := histo[binID];
  696.  end;
  697.  
  698.  barstep := maxval1 div maxbar;   { steps between lines   }
  699.  halfstep := barstep div 2;     { half of one step      }
  700.  y := 0;
  701.  
  702.  for barctr := maxbar downto 1 do
  703.  begin { down bars    }
  704.   barbase := Trunc(barstep * barctr);
  705.   barmid  := barbase + halfstep;
  706.   x := 1;
  707.   for binID := 0 TO maxbit do            { for each bin }
  708.   begin
  709.    if histo[binID] > barmid then
  710.      WriteChar(x,y,Chr(barchar),7,1)
  711.    else if histo[binID] > barbase then
  712.      WriteChar(x,y,Chr(halfbar),7,1)
  713.    else WriteChar(x,y,'_',7,1);
  714.    x := succ(x);
  715.   end;
  716.   y := succ(y);                             { new line       }
  717.  end;
  718.  
  719.  for binID := 0 to maxbit do           { fill in bottom }
  720.   if histo[binID] > halfstep then
  721.     WriteChar(binID+1,y,Chr(barchar),7,1)
  722.   else if histo[binID] > 0 then
  723.     WriteChar(binID+1,y,Chr(halfbar),7,1)
  724.   else WriteChar(binID+1,y,'_',7,1);
  725.  
  726.  y := succ(y);
  727.  x := 1;
  728.  WriteStr(x,y, '0         1         2         3         ' +
  729.                '4         5         6   ',7);
  730.  y :=succ(y);
  731.  WriteStr(x,y,'0123456789012345678901234567890123456789' +
  732.                '012345678901234567890123',7);
  733. end;
  734.  
  735. procedure CCDpgm.InitMenuBar;
  736. var
  737.   R: TRect;
  738. begin
  739.   GetExtent(R);
  740.   R.B.Y := R.A.Y+1;
  741.   MenuBar := New(PMenuBar, Init(R, NewMenu(
  742.     NewSubMenu('~F~ile', 0, NewMenu(
  743.       NewItem('~O~pen ...', 'F3', kbF3, cmFOpen, 0,
  744.       NewItem('~S~ave', 'F2', kbF2, cmFSave, 0,
  745.       NewItem('Save ~A~s ...', '', kbNoKey, cmFSaveAs, 0,
  746.       NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, 0, nil))))),
  747.     NewSubMenu('~E~xpose', 0, NewMenu(
  748.       NewItem('~M~onitor','F9', kbF9, cmExpMon, 0,
  749.       NewItem('~I~ntegrated Exposure ...', 'F10', kbF10, cmExpInteg, 0,
  750.       NewItem('~G~rab', 'Shift-F9', kbShiftF9, cmExpGrab, 0,nil)))),
  751.     NewSubMenu('~M~erge', 0, NewMenu(
  752.       NewItem('~C~ompare Images ...','', kbNoKey, cmMrgCompare, 0,
  753.       NewItem('~A~dd Images ...', '', kbNoKey, cmMrgAdd, 0,
  754.       NewItem('~S~ubtract Images ...', '', kbNoKey, cmMrgSub, 0,
  755.       NewItem('~M~ask Images ...', '', kbNoKey, cmMrgMask, 0,nil))))),
  756.       NewSubMenu('~P~rocess', 0, NewMenu(
  757.       NewItem('~E~dge Enhance','', kbNoKey, cmProEdge, 0,
  758.       NewItem('~F~ilter', '', kbNoKey, cmProFilter, 0,
  759.       NewItem('~H~istogram', '', kbNoKey, cmProHist, 0,
  760.       NewItem('~M~ultiply ...', '', kbNoKey, cmProMult, 0,
  761.       NewItem('~I~nvert', '', kbNoKey, cmProInvert, 0,
  762.       NewItem('~O~ffset', '', kbNoKey, cmProOffset, 0,
  763.       NewItem('~T~hreshold ...', '', kbNoKey, cmProThreshold, 0,nil)))))))),
  764.       NewItem('~D~isplay', '', kbShiftF10, cmDisplay, 0,
  765.       NewSubMenu('~O~ptions', 0, NewMenu(
  766.       NewItem(VgaHiResTxt,'', kbNoKey, cmOptVga, 0,
  767.       NewItem(AutoDisplayTxt, '', kbNoKey, cmOptAutoD, 0,
  768.       NewItem(PhotoModeTxt, '', kbNoKey, cmOptPhotoS, 0,nil)))),
  769.       nil)))))))));
  770. end;
  771.  
  772. procedure CCDpgm.InitStatusLine;
  773. var
  774.   R: TRect;
  775. begin
  776.   GetExtent(R);
  777.   R.A.Y := R.B.Y - 1;
  778.   StatusLine := New(PStatusLine, Init(R,
  779.     NewStatusDef(0, $FFFF,
  780.       NewStatusKey('~F10~ Expose', kbF10, cmExpInteg,
  781.       NewStatusKey('~F9~ Monitor', kbF9, cmExpMon,
  782.       NewStatusKey('~ShiftF9~ Grab', kbShiftF9,cmExpGrab,
  783.       NewStatusKey('~F3~ Open', kbF3, cmFOpen,
  784.       NewStatusKey('~F2~ Save', kbF2, cmFSave,
  785.       NewStatusKey('~AltX~ Exit', kbAltX, cmQuit,
  786.       NewStatusKey('~ShiftF10~ Display', kbShiftF10, cmDisplay, nil))))))), nil)));
  787. end;
  788.  
  789. procedure CCDpgm.FileSaveAs(WildCard: PathStr);
  790. var
  791.   D: PFileDialog;
  792. begin
  793.   D := New(PFileDialog, Init(WildCard, 'Save as',
  794.     '~N~ame', fdOkButton + fdHelpButton, 100));
  795.   D^.HelpCtx := 0;
  796.   if ValidView(D) <> nil then
  797.   begin
  798.     if Desktop^.ExecView(D) <> cmCancel then
  799.     begin
  800.       D^.GetFileName(CurFileName);
  801.       FileSave;
  802.     end;
  803.     Dispose(D, Done);
  804.   end;
  805. end;
  806.  
  807. procedure CCDpgm.FileSave;
  808. begin
  809.   if CurFileName[0] = chr(0) then
  810.     FileSaveAs('*.CCD')
  811.   else
  812.   begin
  813.     if SavePicture(CurFileName,CurPicture) <> 0 then
  814.       MessageBox('Can''t Save File!', nil, mfError + mfOkButton);
  815.   end;
  816. end;
  817.  
  818. procedure CCDpgm.FileOpen(WildCard: PathStr);
  819. var
  820.   D:     PFileDialog;
  821.   wkPic: PicPtr;
  822. begin
  823.   D := New(PFileDialog, Init(WildCard, 'Open a File',
  824.     '~N~ame', fdOpenButton + fdHelpButton, 100));
  825.   D^.HelpCtx := 0;
  826.   if ValidView(D) <> nil then
  827.   begin
  828.     if Desktop^.ExecView(D) <> cmCancel then
  829.     begin
  830.       D^.GetFileName(CurFileName);
  831.       PicSetup(CurPicture);
  832.       if LoadPicture(CurFileName,CurPicture) <> 0 then
  833.         MessageBox('Error Loading File!', nil, mfError + mfOkButton)
  834.     end;
  835.     Dispose(D, Done);
  836.   end;
  837. end;
  838.  
  839. procedure CCDpgm.DisplayImage;
  840. begin
  841.   GraphicsStart;
  842.   Display_Image(CurPicture);
  843.   ReadKey;
  844.   GraphicsStop;
  845. end;
  846.  
  847. procedure CCDpgm.SetMenuItem(Item: string; Value: boolean);
  848. var
  849.   mText : TMenuStr;
  850.  
  851. function SearchItem(pI : PMenuItem): boolean;
  852. begin
  853.   if pI = NIL then
  854.     SearchItem := true
  855.   else if Pos(mText,pI^.Name^) <> 0 then
  856.   begin
  857.     SearchItem := false;
  858.     if Value then
  859.       pI^.Name^ := Concat(mText,OnTxt)
  860.     else
  861.       pI^.Name^ := Concat(mText,OffTxt)
  862.   end
  863.   else
  864.     SearchItem := SearchItem(pI^.Next);
  865. end;
  866.  
  867. var
  868.   pI: PMenuItem;
  869. begin
  870.   mText := Copy(Item,1,Length(Item)-3);
  871.   pI := MenuBar^.Menu^.Items;
  872.   while pI <> NIL DO
  873.   begin
  874.     if pI^.SubMenu <> NIL then
  875.       if not SearchItem(pI^.SubMenu^.Items) then
  876.         pI := Nil
  877.       else
  878.         pI := pI^.Next
  879.     else
  880.       pI := pI^.Next;
  881.   end;
  882. end;
  883.  
  884. procedure NotImplemented;
  885. begin
  886.   MessageBox('This command has not been implemented yet!', nil, mfError + mfOkButton);
  887. end;
  888.  
  889. procedure CCDpgm.UpdateHistoGram;
  890. begin
  891.   if (HistoGram <> NIL) and (CurPicture <> NIL) then
  892.   begin
  893.     HistoGram^.HistoView^.Update(CurPicture)
  894.   end;
  895. end;
  896.  
  897. procedure CCDpgm.HandleEvent(var Event: TEvent);
  898. var
  899.   wkStr:         PathStr;
  900.   wkI,Result:    integer;
  901.   DoAutoDisplay: boolean;
  902.   wkPicture:     PicPtr;
  903.   resPicture:    PicPtr;
  904. begin
  905.   DoAutoDisplay := false;
  906.   TApplication.HandleEvent(Event);
  907.   case Event.What of
  908.     evCommand:
  909.       begin
  910.         case Event.Command of
  911.           cmFOpen:        begin
  912.                             FileOpen('*.CCD');
  913.                             UpdateHistoGram;
  914.                             DoAutoDisplay := true;
  915.                           end;
  916.           cmFSave:        FileSave;
  917.           cmFSaveAs:      FileSaveAs('*.CCD');
  918.           cmExpMon:       begin
  919.                             GraphicsStart;
  920.                             if not Continuous(CurPicture) then
  921.                             begin
  922.                               GraphicsStop;
  923.                               MessageBox('Camera not responding!', nil, mfError + mfOkButton);
  924.                               if CurPicture <> NIL then
  925.                               begin
  926.                                 dispose(CurPicture);
  927.                                 CurPicture := NIL;
  928.                               end;
  929.                             end
  930.                             else
  931.                               GraphicsStop;
  932.                           end;
  933.           cmExpInteg:     NotImplemented;
  934.           cmExpGrab:      begin
  935.                              PicSetup(CurPicture);
  936.                              SetSyncs(CurPicture);
  937.                              if Capture then
  938.                                Scan(CurPicture)
  939.                              else
  940.                                MessageBox('Camera not responding!', nil, mfError + mfOkButton);
  941.                           end;
  942.           cmMrgCompare:   if (CurPicture = NIL) then
  943.                             MessageBox('No picture!', nil, mfError + mfOkButton)
  944.                           else
  945.                           begin
  946.                             WkPicture := CurPicture;
  947.                             CurPicture := NIL;
  948.                             FileOpen('*.CCD');
  949.                             Compare(WkPicture,CurPicture);
  950.                             Dispose(CurPicture);
  951.                             CurPicture:= WkPicture;
  952.                             UpdateHistoGram;
  953.                             DoAutoDisplay := true;
  954.                           end;
  955.           cmMrgAdd:       if (CurPicture = NIL) then
  956.                             MessageBox('No picture!', nil, mfError + mfOkButton)
  957.                           else
  958.                           begin
  959.                             WkPicture := CurPicture;
  960.                             CurPicture := NIL;
  961.                             FileOpen('*.CCD');
  962.                             Add(WkPicture,CurPicture);
  963.                             Dispose(CurPicture);
  964.                             CurPicture:= WkPicture;
  965.                             UpdateHistoGram;
  966.                             DoAutoDisplay := true;
  967.                           end;
  968.           cmMrgSub:       if (CurPicture = NIL) then
  969.                             MessageBox('No picture!', nil, mfError + mfOkButton)
  970.                           else
  971.                           begin
  972.                             WkPicture := CurPicture;
  973.                             CurPicture := NIL;
  974.                             FileOpen('*.CCD');
  975.                             Subtract(WkPicture,CurPicture);
  976.                             Dispose(CurPicture);
  977.                             CurPicture:= WkPicture;
  978.                             UpdateHistoGram;
  979.                             DoAutoDisplay := true;
  980.                           end;
  981.           cmMrgMask:      if (CurPicture = NIL) then
  982.                             MessageBox('No picture!', nil, mfError + mfOkButton)
  983.                           else
  984.                           begin
  985.                             WkPicture := CurPicture;
  986.                             CurPicture := NIL;
  987.                             FileOpen('*.CCD');
  988.                             Mask(WkPicture,CurPicture);
  989.                             Dispose(CurPicture);
  990.                             CurPicture:= WkPicture;
  991.                             UpdateHistoGram;
  992.                             DoAutoDisplay := true;
  993.                           end;
  994.           cmProEdge:      begin
  995.                             if (CurPicture = NIL) then
  996.                               MessageBox('No picture!', nil, mfError + mfOkButton)
  997.                             else
  998.                             begin
  999.                               wkPicture:= NIL;                   { get output array      }
  1000.                               PicSetup(wkPicture);
  1001.                               SetSyncs(wkPicture);
  1002.                               Edge(CurPicture,wkPicture);
  1003.                               Dispose(CurPicture);
  1004.                               CurPicture:= wkPicture;
  1005.                               UpdateHistoGram;
  1006.                               DoAutoDisplay := true;
  1007.                             end;
  1008.                           end;
  1009.           cmProFilter:    begin
  1010.                             if (CurPicture = NIL) then
  1011.                               MessageBox('No picture!', nil, mfError + mfOkButton)
  1012.                             else
  1013.                             begin
  1014.                               wkPicture := NIL;
  1015.                               PicSetup(wkPicture);
  1016.                               SetSyncs(wkPicture);
  1017.                               Filter1(CurPicture,wkPicture);
  1018.                               Dispose(CurPicture);
  1019.                               CurPicture := wkPicture;
  1020.                               UpdateHistoGram;
  1021.                               DoAutoDisplay := true;
  1022.                             end;
  1023.                           end;
  1024.           cmProHist:      begin
  1025.                             if (CurPicture = NIL) then
  1026.                               MessageBox('No picture!', nil, mfError + mfOkButton)
  1027.                             else
  1028.                             begin
  1029.                               HistoGram := new(pHistoWindow,Init);
  1030.                               Desktop^.Insert(ValidView(HistoGram));
  1031.                             end
  1032.                           end;
  1033.           cmProMult:      if (CurPicture = NIL) then
  1034.                             MessageBox('No picture!', nil, mfError + mfOkButton)
  1035.                           else
  1036.                           begin
  1037.                             if TypeInDialog(wkStr,'Enter Mult Factor') then
  1038.                             begin
  1039.                               Val(wkStr,wkI,Result);
  1040.                               if Result = 0 then
  1041.                                  Multiply(CurPicture,wkI);
  1042.                               DoAutoDisplay := true;
  1043.                               UpdateHistoGram;
  1044.                             end;
  1045.                           end;
  1046.           cmProInvert:    begin
  1047.                             if (CurPicture = NIL) then
  1048.                               MessageBox('No picture!', nil, mfError + mfOkButton)
  1049.                             else
  1050.                             begin
  1051.                               Invert(CurPicture);
  1052.                               DoAutoDisplay := true;
  1053.                               UpdateHistoGram;
  1054.                             end;
  1055.                           end;
  1056.           cmProOffset:    if (CurPicture = NIL) then
  1057.                             MessageBox('No picture!', nil, mfError + mfOkButton)
  1058.                           else if TypeInDialog(wkStr,'Enter Offset') then
  1059.                           begin
  1060.                             Val(wkStr,wkI,Result);
  1061.                             if Result = 0 then
  1062.                             begin
  1063.                               if (wkI<0) then
  1064.                               begin
  1065.                                wkI:= abs(wkI);
  1066.                                Negoffset(CurPicture,wkI);
  1067.                               end
  1068.                               else
  1069.                                 Offset(CurPicture,wkI);
  1070.                               DoAutoDisplay := true;
  1071.                               UpdateHistoGram;
  1072.                             end;
  1073.                           end;
  1074.           cmProThreshold: if (CurPicture = NIL) then
  1075.                             MessageBox('No picture!', nil, mfError + mfOkButton)
  1076.                           else if TypeInDialog(wkStr,'Enter Threshold') then
  1077.                           begin
  1078.                             Val(wkStr,wkI,Result);
  1079.                             if Result = 0 then
  1080.                               Threshold(CurPicture,wkI);
  1081.                             DoAutoDisplay := true;
  1082.                             UpdateHistoGram;
  1083.                           end;
  1084.           cmDisplay:      DisplayImage;
  1085.           cmOptVga:       begin
  1086.                             VGAhiRes    := not VGAhiRes;
  1087.                             SetMenuItem(VgaHiResTxt,VGAhiRes);
  1088.                           end;
  1089.           cmOptAutoD:     begin
  1090.                             AutoDisplay := not AutoDisplay;
  1091.                             SetMenuItem(AutoDisplayTxt,AutoDisplay);
  1092.                           end;
  1093.           cmOptPhotoS:    begin
  1094.                             PhotoMode   := not PhotoMode;
  1095.                             SetMenuItem(PhotoModeTxt,PhotoMode);
  1096.                           end;
  1097.         else
  1098.           Exit;
  1099.         end;
  1100.         ClearEvent(Event);
  1101.         if DoAutoDisplay and AutoDisplay then
  1102.           DisplayImage;
  1103.       end;
  1104.   end;
  1105. end;
  1106.  
  1107. begin
  1108.   CCD.Init;
  1109.   CCD.CurPicture := NIL;
  1110.   CCD.CurFileName    := '';
  1111.   CCD.SetMenuItem(VgaHiResTxt,False);
  1112.   CCD.SetMenuItem(AutoDisplayTxt,False);
  1113.   CCD.SetMenuItem(PhotoModeTxt,False);
  1114.   VGAhiRes     := FALSE;
  1115.   AutoDisplay  := FALSE;
  1116.   PhotoMode    := FALSE;
  1117.   CCD.Run;
  1118.   CCD.Done;
  1119. end.
  1120.  
  1121.  
  1122. [LISTING THREE]
  1123.  
  1124. unit Vga;
  1125. {*******************************************************}
  1126.  
  1127. interface
  1128. USES Video, DOS, CRT;
  1129. var
  1130.   VGAhiRes:         boolean;
  1131.   AutoDisplay:      boolean;
  1132.   PhotoMode:        boolean;
  1133.  
  1134. Procedure Display_Image(pic1: PicPtr);
  1135. function Continuous(var pic1: PicPtr): boolean;
  1136.  
  1137. implementation
  1138.  
  1139. {--- Sets the VGA display planes            }
  1140. Procedure Set_Plane (plane : byte);
  1141.  
  1142. var old : byte;
  1143.  
  1144. begin
  1145.   Port[$01CE] := $0B2;        { plane select mask    }
  1146.   old := (Port[$01CF] and $0E1); { get the old plane value }
  1147.   Port[$01CE] := $0B2;        { plane select mask    }
  1148.   Port[$01CF] := ((plane shl 1) or old); { new plane register value }    
  1149.  
  1150. end;
  1151.  
  1152. procedure DisplayInVgaMode(pic1: PicPtr);
  1153. begin
  1154. (*
  1155.     col := 32;
  1156.     for row := 0 to 200 do
  1157.     begin
  1158.       Move(pic1^.fmt.lines[row].pels[0],MEM[$A000:col],256);
  1159.       col := col + 320;
  1160.     end;
  1161. *)
  1162.       asm
  1163.                 push    ds
  1164.                 lds     si,pic1
  1165.                 inc     si        (*Sync1*)
  1166.                 mov     bx,201
  1167.                 mov     ax,0A000H
  1168.                 mov     es,ax
  1169.                 mov     di,32
  1170.                 cld
  1171. @LineLoop:      inc     si        (*SyncL*)
  1172.                 mov     cx,128
  1173.            rep  movsw
  1174.                 add  di,320-256
  1175.                 dec     bx
  1176.                 jne     @LineLoop
  1177.                 pop     ds
  1178.       end;
  1179. end;
  1180.  
  1181. {--- Show picture on VGA in 320x200x256 or        }
  1182. {    640x400x256 color mode                }
  1183. Procedure Display_Image(pic1: PicPtr);
  1184.  
  1185. var
  1186.  r         : registers;         { BIOS interface regs   }
  1187.  row,col   : INTEGER;           { Screen coordinates    }
  1188.  Vmode     : char;
  1189.  shade     : byte;
  1190.  mode, i   : integer;
  1191.  plane     : byte;
  1192.   
  1193. const
  1194.  VideoInt    : byte    = $10;
  1195.  Set_DAC_Reg : integer = $1010;
  1196.  
  1197. begin
  1198.   if VGAhiRes then
  1199.   begin
  1200.     r.AX := ($00 SHL 8) OR $61;
  1201.     Intr(VideoInt,r);              { set 640x400x256 color mode}
  1202.     mode := 1;
  1203.   end
  1204.   else
  1205.   begin
  1206.     r.AX := ($00 SHL 8) OR $13;
  1207.     Intr(VideoInt,r);              { set 320x200x256 color mode}
  1208.     mode := 0;
  1209.   end;
  1210.   for shade := 0 to 63 do
  1211.   begin
  1212.     r.ax  := Set_DAC_Reg;
  1213.     r.bx  := shade;
  1214.     r.ch  := shade;
  1215.     r.cl  := shade;
  1216.     r.dh  := shade;
  1217.     INTR(VideoInt,r);
  1218.   end;
  1219.   if mode = 0 then
  1220.   begin
  1221.     DisplayInVgaMode(pic1);
  1222.   end
  1223.   else
  1224.   begin
  1225.     for row := 0 to 102 do
  1226.     begin
  1227.       col := row * 640;
  1228.       Move(pic1^.fmt.lines[row].pels[0],MEM[$A000:col],256);
  1229.     end;
  1230.     plane := 1;
  1231.     Set_Plane ( plane );
  1232.     for row := 103 to 204 do
  1233.     begin
  1234.       col := (row - 103) * 640 + 384;
  1235.       Move(pic1^.fmt.lines[row].pels[0],MEM[$A000:col],256);
  1236.     end;
  1237.     plane := 2;
  1238.     Set_Plane ( plane );
  1239.     for row := 205 to 240 do
  1240.     begin
  1241.       col := (row - 205) * 640 + 128;
  1242.       Move(pic1^.fmt.lines[row].pels[0],MEM[$A000:col],256);
  1243.     end;
  1244.   end;
  1245. end;
  1246.  
  1247. function Continuous(var pic1: PicPtr): boolean;
  1248. var
  1249.  r         : registers;         { BIOS interface regs   }
  1250.  row,col   : INTEGER;           { Screen coordinates    }
  1251.  Vmode     : char;
  1252.  shade     : byte;
  1253.  cont      : boolean;
  1254. CONST
  1255.  VideoInt    : byte    = $10;
  1256.  Set_DAC_Reg : integer = $1010;
  1257.  
  1258. begin
  1259.  PicSetup(pic1);                  { set up even picture array  }
  1260.  SetSyncs(pic1);
  1261.  
  1262.  r.AX := ($00 SHL 8) OR $13;
  1263.  Intr(VideoInt,r);              { set 320x200x256 color mode }
  1264.  
  1265.  FOR shade := 0 to 63 do begin        { set VGA to gray scale }
  1266.      r.ax  := Set_DAC_Reg;
  1267.      r.bx  := shade;
  1268.      r.ch  := shade;
  1269.      r.cl  := shade;
  1270.      r.dh  := shade;
  1271.      INTR(VideoInt,r);
  1272.      End;
  1273.   repeat
  1274.     if capture then
  1275.     begin
  1276.       scan(pic1);
  1277.       DisplayInVgaMode(pic1);
  1278.       Cont := true;
  1279.     end
  1280.     else
  1281.       Cont := false;
  1282.   until not Cont or KeyPressed;
  1283.   Continuous := Cont;
  1284. END;
  1285. end.
  1286.  
  1287.  
  1288.  
  1289.