1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:

{ Einstellung Vers. 2.1 vom 29.6.01 }
program test_ccd;

uses kds_ccd,
     crt;

var i           : integer;
    c           : char;
    t           : single;
    f           : integer;
    g           : integer;
    k, n        : longint;
    bgnd        : longint;   (* Untergrund-Level *)
    min_c       : integer;   (* Schwellwert      *)
    s           : string;
    fn          : string;
    f1, f2      : text;
    fx          : integer;
    fy          : integer;
    fak         : double;
    f_low       : integer;
    f_high      : integer;
    c_low       : longint;
    c_high      : longint;
    n_low       : integer;
    n_high      : integer;
    p_low       : integer;
    p_high      : integer;
    x, y        : double;
    ce_x, ce_y, ce_r : double;
    ca_x, ca_y, ca_r : double;
    ch          : longint;
    spk         : array [0..1000] of longint;
    olddir, curdir: String;

procedure help_screen;
  begin
    writeln;
    writeln(' a: Messung starten');
    writeln(' d: Untergrund abziehen');
    writeln(' i: Bild zeigen');
    writeln(' m: Mehrfachmessung');
    writeln(' q: Programmende');
    writeln(' t: Messzeit setzen');
  end;

begin
  Writeln('Daten werden nach C:\Dataloc geschrieben');
  GetDir(0,OldDir);
  ccd_init;
  readln;
  show_ccd_hardware;
  readln;
  writeln(' CCD-Meáablaufsteuerung');
  writeln;
  c:='h';
  t:=1;
  g:=0;
  repeat
    writeln;
    case c of

      'a' : begin
              start_ccd_acq(g,round(1000*t));
              writeln(' acquisition start');
              repeat until ccd_busy<4;
              writeln(' flushing');
              repeat until ccd_busy<3;
              writeln(' acquisition runing');
              repeat until ccd_busy<2;
              writeln(' acquisition ready');
              repeat until ccd_busy=0;
              writeln(' ccd readout ready');
              ccd_transfer_image;
              writeln(' data transfer ready');
              writeln(' OK');
            end;

      'b' : begin
              write(' Start-Level : ');
              readln(bgnd);
              write(' Such-Breite : ');
              readln(n);
              bgnd:=ccd_compute_bgnd(bgnd, n);
              writeln(' Untergrund  : ', bgnd);
            end;

      'd' : begin
              writeln(' Untergrundabzug');
              ccd_sub_bgnd(bgnd);
              writeln(' OK');
            end;

      'i' : begin
              show_image;
            end;

      'm' : begin
              GetDir(0,OldDir);
              write(' Filename (Event-Liste) : ');
              readln(fn);
              write(' Anzahl der Meázyklen   : ');
              readln(n);
              write(' Meázeit in s           : ');
              readln(t);
              write(' Threshold              : ');
              readln(min_c);
              ChDir('C:\Dataloc');
              {$I-}
               ChDir('C:\Dataloc');
               if IOResult<>0
               then begin
                 Writeln('Netzlaufwerk nicht verf?gbar');
                 Writeln('verwende aktuelles Verzeichnis');
               end;
              {$I+}
              for i:=1 to n do
                begin
                  start_ccd_acq(g,round(1000*t));
                  write(i:5,'  ');
                  {$I-}
                  assign(f1,fn);
                  reset(f1);
                  if IOResult=0 then
                    begin
                      close(f1);
                      append(f1);
                    end
                  else
                    rewrite(f1);
                  writeln(f1,'# Frame #',i);
                  close(f1);
                  {$I+}
                  repeat until ccd_busy<3;
                  write('a');
                  repeat until ccd_busy<2;
                  write('r');
                  repeat until ccd_busy=0;
                  write('d');
                  ccd_transfer_image;
                  write('b ');
                  write(ccd_compute_bgnd(bgnd, 50));
                  ccd_sub_bgnd(bgnd);
                  write(' e ');
                  write(ccd_event_list(fn,min_c));
                  writeln(' OK');
                end;
              writeln(' READY');
              ChDir(OldDir);
            end;

      't' : begin
              write(' Meßzeit in s :');
              readln(t);
              writeln(' OK');
            end;

      end;

    write(' CCD> ');
    repeat until keypressed;
    c:=readkey;
  until c='q';
  free_ccd;
end.					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:
487:
488:
489:
490:
491:
492:
493:
494:
495:
496:
497:
498:
499:
500:
501:
502:
503:
504:
505:
506:
507:
508:
509:
510:
511:
512:
513:
514:
515:
516:
517:
518:
519:
520:
521:
522:
523:
524:
525:
526:
527:
528:
529:
530:
531:
532:
533:
534:
535:
536:
537:
538:
539:
540:
541:
542:
543:
544:
545:
546:
547:
548:
549:
550:
551:
552:
553:
554:
555:
556:
557:
558:
559:
560:
561:
562:
563:
564:
565:
566:
567:
568:
569:
570:
571:
572:
573:
574:
575:
576:
577:
578:
579:
580:
581:
582:
583:
584:
585:
586:
587:
588:
589:
590:
591:
592:
593:
594:
595:
596:
597:
598:
599:
600:
601:
602:
603:
604:
605:
606:
607:
608:
609:
610:
611:
612:
613:
614:
615:
616:
617:
618:
619:
620:
621:
622:
623:
624:
625:
626:
627:
628:
629:
630:
631:
632:
633:
634:
635:
636:
637:
638:
639:
640:
641:
642:
643:
644:
645:
646:
647:
648:
649:
650:
651:
652:
653:
654:
655:
656:
657:
658:
659:
660:
661:
662:
663:
664:
665:
666:
667:
668:
669:
670:
671:
672:
673:
674:
675:
676:
677:
678:
679:
680:
681:
682:
683:
684:
685:
686:
687:
688:
689:
690:
691:
692:
693:
694:
695:
696:
697:
698:
699:
700:
701:
702:
703:
704:
705:
706:
707:
708:
709:
710:
711:
712:
713:
714:
715:
716:
717:
718:
719:
720:
721:
722:
723:
724:
725:
726:
727:
728:
729:
730:
731:
732:
733:
734:
735:
736:
737:
738:
739:
740:
741:
742:
743:
744:
745:
746:
747:
748:
749:
750:
751:
752:
753:
754:
755:
756:
757:
758:
759:
760:
761:
762:
763:
764:
765:
766:
767:
768:
769:
770:
771:
772:
773:
774:
775:
776:
777:
778:
779:
780:
781:
782:
783:
784:
785:
786:
787:
788:
789:
790:
791:
792:
793:
794:
795:
796:
797:
798:
799:
800:
801:
802:
803:
804:
805:
806:
807:
808:
809:
810:
811:
812:
813:
814:
815:
816:
817:
818:
819:
820:
821:
822:
823:
824:
825:
826:
827:
828:
829:
830:
831:
832:
833:
834:
835:
836:
837:
838:
839:
840:
841:
842:
843:
844:
845:
846:
847:
848:
849:
850:
851:
852:
853:
854:
855:
856:
857:
858:
859:
860:
861:
862:
863:
864:
865:
866:
867:
868:
869:
870:
871:
872:
873:
874:
875:
876:
877:
878:
879:
880:
881:
882:
883:
884:
885:
886:
887:
888:
889:
890:
891:
892:
893:
894:
895:
896:
897:
898:
899:
900:
901:
902:
903:
904:
905:
906:
907:
908:
909:
910:

unit kds_ccd;

{ diese Unit stellt die Funktionalität des I.S.A. CCD-Treibers       }
{ externen Programmen zur Verfügung                                  }

interface

uses dos,
     crt,
     ems,
     graph;

procedure ccd_init;
{ initialisiert den CCD-Treiber und die CCD-Hardware                 }

procedure show_ccd_hardware;
{ zeigt alle möglichen Informationen zur CCD-Hardware an             }

procedure start_ccd_acq ( gain : integer;
                          time : longint);
{ startet eine Messung mit der angegebenen Meßzeit und der           }
{ angegebenen Verstärkung                                            }

function  ccd_busy : integer;
{ liefert eine Information über den Ablauf einer Messung             }
{ die Meßdaten sind verfügbar wenn ccd_busy 0 liefert                }
{ diese Funktion muß für einen korrekten Meßablauf ständig           }
{ aufgerufen werden                                                  }

procedure  ccd_transfer_image;
{ lädt die Daten einer Messung aus dem Controller in den Speicher    }

procedure  ccd_load_image (fn     : string );
{ diese Funktion lädt ein CCD-Image von Diskette/Festplatte          }

procedure  ccd_save_image (fn     : string );
{ diese Funktion sichert ein CCD-Image aus Diskette/Festplatte       }

function   ccd_compute_bgnd(level, breite:integer) : integer;
{ diese Funktion berechnet die Höhe des Untergrundes eines Bildes    }
{ das bisherige Untergrundlevel und eine Variationsbreite werden     }
{ zur Unterdrückung von Bildpunkten mit Signalladung angegeben       }

procedure  ccd_sub_bgnd(level:integer);
{ zieht einen konstanten Untergrund von Ladungsbild ab               }

procedure  ccd_tga_image (fn : string; g : double; c : integer);
{ diese Funktion sichert ein CCD-Image aus Diskette/Festplatte       }
{ im TARGA Fileformat, c gibt die Farbvariante an (0...6)            }

procedure  ccd_clear_image;
{ löscht den Bildspeicher                                            }

function   ccd_event_list (fn     : string;
                           limit  : integer ) : longint;
{ analysiert das Bild auf zusammenhängende Pixel                     }
{ und erstellt ein Event-Listen-File                                 }
{ zurückgegeben wird die Anzahl der Events                           }

procedure  ccd_event_image (fn        : string;
                            fx, fy    : integer;
                            gauss_mod : boolean;
                            fak       : real);
{ lädt eine Event-Liste als Bild                                     }
{ dabei werden die Pixel zu Vierecken oder Gaußpeaks der Größe fx*fy }
{ aufgeblasen, und mit einem Faktor fak/fx*fy skaliert               }

procedure  show_image;
{ zeigt den Inhalt des Bildspeichers als Falschfarbenbild an         }

procedure  rad_spek(fn:string; x,y:double);
{ speichert Bilddaten als radiale Ortsverteilung                     }

procedure  free_ccd;
{ gibt den für Bildspeicher und Untergrund belegten Speicher frei    }
{ muß vor Programmende aufgerufen werden                             }

implementation

const ccd_number    : byte = 1;

type  t_chip_data   = record
                        number        : byte;
                        port          : integer;
                        act_pixels_x  : integer;
                        act_pixels_y  : integer;
                        pass_y_before : integer;
                        pass_y_after  : integer;
                        pass_x_before : integer;
                        pass_x_after  : integer;
                        scan_dir      : byte;
                        min_t         : integer;
                        max_t         : integer;
                        min_shutter   : longint;
                        max_shutter   : longint;
                        min_gain      : word;
                        max_gain      : word;
                        h_pix_space   : integer;
                        v_pix_space   : integer;
                        tot_pix_x     : integer;
                        tot_pix_y     : integer;
                        int_time      : word;
                      end;

type  t_ccd_area    = record
                        data_ptr      : pointer;
                        x_offs        : integer;
                        y_offs        : integer;
                        size_x        : integer;
                        size_y        : integer;
                        bin_x         : integer;
                        bin_y         : integer;
                      end;

type  t_ccd_user    = record
                        number        : byte;
                        acq_format    : byte;
                        n_areas       : integer;
                        area_ptr      : ^t_ccd_area;
                      end;

type  t_image_page  = array[0..20,0..384] of integer;
      p_image_page  = ^t_image_page;
{ ein Segment eines CCD-Images das in einen EMS-Frame paßt           }
{ für ein vollständiges Image werden 28 Frames benötigt              }

var  ccd_data_buffer  : array [0..415] of word;

const bgi_driver_flag : integer = 0;

var   image_ptr       : p_image_page;
      image_handle    : integer;
      image_page      : integer;

procedure EgaVgaDriverProc; external;
{$L EGAVGA.OBJ }

procedure vgainit;
  var GraphDriver : integer;
      GraphMode   : integer;
  procedure Abort(Msg : string);
    begin
      Writeln(Msg, ': ', GraphErrorMsg(GraphResult));
      writeln('press <ENTER>');
      readln;
      Halt(1);
    end;
  begin
    GraphDriver:= 9;                  { VGA-Grafik                   }
    GraphMode  := 2;                  { 640*480 HiRes                }
    if bgi_driver_flag = 0 then
      begin
        if RegisterBGIdriver(@EGAVGADriverProc) < 0 then
          Abort('EGA/VGA');
        bgi_driver_flag:=1;
      end;
    InitGraph(GraphDriver,GraphMode, '');
    if GraphResult <> grOk then
      begin
        Writeln;
        writeln;
        Writeln('Graphics init error: ', GraphErrorMsg(GraphDriver));
        Halt(1);
      end;
  end;

var   ccd_interrupt : byte;
      ccd_data      : t_chip_data;
      my_area       : t_ccd_area;
      my_user       : t_ccd_user;

function  is_driver_loaded : word; far;
  var reg : registers;
  begin
    reg.ah:=$a2;
    reg.bx:=0;
    intr($11, reg);
    is_driver_loaded:=reg.bx;
  end;

function ccd_driver( command   : word;
                     param_ptr : pointer ) : pointer; far;
  var  reg : registers;
  begin
    reg.ds:=seg(param_ptr^);
    reg.dx:=ofs(param_ptr^);
    reg.ax:=command;
    intr(ccd_interrupt, reg);
    if reg.ax=0 then
      ccd_driver:=ptr(reg.ds, reg.dx)
    else
      begin
        writeln;
        writeln(' error Nr.',reg.ax,' in CCD-driver !');
        readln;
      end;
  end;

procedure ccd_init;
  type driver = record
                  version : array[1..15] of char;
                  id      : array[1..11] of char;
                end;
  var  driver_ptr : ^driver;
       int_ptr    : ^integer;
       i          : integer;
  begin
    ccd_interrupt:=is_driver_loaded;
    if ccd_interrupt=0 then
      begin
        writeln(' CCD-Interrupt nicht bestimmbar');
        readln;
        halt(1);
      end;
    writeln(' CCD-Interrupt   : ',ccd_interrupt);
    driver_ptr:=ccd_driver(0,ptr(0,0));
    writeln(' Treiber-Version : ',driver_ptr^.version);
    writeln(' Treiber-ID      : ',driver_ptr^.id);
    int_ptr:=ccd_driver(300,@ccd_number);
    writeln(' CCD-Hardware    : ',int_ptr^);
    int_ptr:=ccd_driver(303,@ccd_number);
    writeln(' CCD-Gain        : ',int_ptr^);
    int_ptr:=ccd_driver(308,@ccd_number);
    writeln(' CCD-Temperatur  : ',int_ptr^);
  end;

procedure show_ccd_hardware;
  var hardware_ptr  : ^t_chip_data;
  begin
    ccd_data.number:=ccd_number;
    hardware_ptr:=ccd_driver(310,@ccd_data);
    with hardware_ptr^ do
      begin
        writeln(' CCD-Nummer    : ',number);
        writeln(' Port          : ',port);
        writeln(' active Pixel  : ',act_pixels_x,' * ',act_pixels_y);
        writeln(' Rand x        : ',pass_x_before,'   ',pass_x_after);
        writeln(' Rand y        : ',pass_y_before,'   ',pass_y_after);
        writeln(' scan-Richtung : ',scan_dir);
        writeln(' Temperaturen  : ',min_t,' ... ',max_t);
        writeln(' Shutter       : ',min_shutter,' ... ',max_shutter);
        writeln(' Verst?rkung   : ',min_gain,' ... ',max_gain);
        writeln(' Pixelabstand  : ',h_pix_space,' * ',v_pix_space);
        writeln(' Pixel total   : ',tot_pix_x,' * ',tot_pix_y);
        writeln(' DC-Int.-Zeit  : ',int_time);
      end;
  end;

procedure start_ccd_acq ( gain : integer;
                          time : longint);
  var acq_ptr  : ^integer;
      acq_time : record
                   num  : byte;
                   time : longint;
                 end;
      acq_gain : record
                   num  : byte;
                   gain : word;
                 end;
  begin
    with my_area do
      begin
        data_ptr:=nil;
        x_offs:=0;
        x_offs:=0;
        size_x:=ccd_data.tot_pix_x;
        size_y:=ccd_data.tot_pix_y;
        bin_x:=1;
        bin_y:=1;
      end;
    with my_user do
      begin
        number:=ccd_number;
        acq_format:=0;
        n_areas:=1;
        area_ptr:=@my_area;
      end;
    acq_ptr:=ccd_driver(304,@my_user);
    my_area.data_ptr:=@ccd_data_buffer;
    acq_time.num:=ccd_number;
    acq_time.time:=time;
    ccd_driver(301,@acq_time);
    acq_gain.num:=ccd_number;
    acq_gain.gain:=gain;
    ccd_driver(302,@acq_gain);
    ccd_driver(311,@ccd_number);
  end;

function ccd_busy : integer;
  var ptr : ^integer;
  begin
    ptr:=ccd_driver(312,@ccd_number);
    ccd_busy:=ptr^;
  end;

procedure  ccd_transfer_image;
  var i, k : integer;
      page : integer;
      line : integer;
  begin
    ccd_driver(317,@ccd_number);
    page:=0;
    line:=0;
    ems_map(image_handle,page,image_page);
    for i:=0 to 577 do
      begin
        ccd_driver(315,@ccd_number);
        for k:=0 to 384 do
          if ccd_data_buffer[k]<MaxInt then
            image_ptr^[line,k]:=ccd_data_buffer[k]
          else
            image_ptr^[line,k]:=MaxInt;
        inc(line);
        if line>20 then
          begin
            line:=0;
            inc(page);
            ems_map(image_handle,page,image_page);
          end;
      end;
  end;

procedure  ccd_clear_image;
  var i, j, k  : integer;
  begin
    for i:=0 to 27 do
      { Schleife über die zum Bild gehörenden EMS-Frames             }
      begin
        ems_map(image_handle,i,image_page);
        for j:=0 to 20 do
          for k:=0 to 384 do
            image_ptr^[j,k]:=0;
      end;
  end;

procedure  ccd_load_image (fn     : string );
  var i, j, k  : integer;
      f        : file of t_image_page;
  begin
    {$I-}
    assign(f,fn);
    reset(f);
    {$I+}
    if IOResult=0 then
      begin
        for i:=0 to 27 do
          { Schleife über die zum Bild gehörenden EMS-Frames             }
          begin
            ems_map(image_handle,i,image_page);
            read(f,image_ptr^);
          end;
        writeln(' Image geladen.');
      end;
    {$I-}
    close(f);
    {$I+}
  end;

procedure  ccd_save_image (fn     : string );
  var i        : integer;
      f        : file of t_image_page;
  begin
    {$I-}
    assign(f,fn);
    rewrite(f);
    {$I+}
    if IOResult=0 then
      for i:=0 to 27 do
        { Schleife über die zum Bild gehörenden EMS-Frames             }
        begin
          ems_map(image_handle,i,image_page);
          write(f,image_ptr^);
        end;
    close(f);
    writeln(' Image gesichert.');
  end;

procedure ccd_tga_image (fn : string;
                         g  : double;
                         c  : integer);
  var i, k  : integer;
      ch    : integer;
      line  : integer;
      page  : integer;
      f     : text;
  begin
    {$I-}
    assign(f,fn);
    rewrite(f);
    {$I+}
    if IOResult=0 then
      begin
        write(f, #0,#1,#1,#0,
                 #0,#0,#1,#$18,
                 #0,#0);
        write(f, #0,#0);                { erste Zeile                    }
        write(f, #144,#1,               { Höhe 400                       }
                 #66,#2);               { Breite 578                     }
        write(f, #8);                   { 8 bit pro pixel                }
        write(f, #$20);                 { top down raster                }
        case c of
        0 : for i:=0 to 255 do          { Farbpalette 256 Graustufen     }
              begin
                write(f, chr(i));
                write(f, chr(i));
                write(f, chr(i));
              end;
        1 : for i:=0 to 255 do          { Farbpalette rgb                }
              begin
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255+1)))));
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255-0.173)/sqr(0.173)))));
                write(f, chr(round(255*(1-i/255)*sqr(i/255-0.25)/sqr(0.25))));
              end;
        2 : for i:=0 to 255 do          { Farbpalette rbg                }
              begin
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255+1)))));
                write(f, chr(round(255*(1-i/255)*sqr(i/255-0.25)/sqr(0.25))));
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255-0.173)/sqr(0.173)))));
              end;
        3 : for i:=0 to 255 do          { Farbpalette brg                }
              begin
                write(f, chr(round(255*(1-i/255)*sqr(i/255-0.25)/sqr(0.25))));
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255+1)))));
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255-0.173)/sqr(0.173)))));
              end;
        4 : for i:=0 to 255 do          { Farbpalette bgr                }
              begin
                write(f, chr(round(255*(1-i/255)*sqr(i/255-0.25)/sqr(0.25))));
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255-0.173)/sqr(0.173)))));
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255+1)))));
              end;
        5 : for i:=0 to 255 do          { Farbpalette grb                }
              begin
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255-0.173)/sqr(0.173)))));
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255+1)))));
                write(f, chr(round(255*(1-i/255)*sqr(i/255-0.25)/sqr(0.25))));
              end;
        6 : for i:=0 to 255 do          { Farbpalette gbr                }
              begin
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255-0.173)/sqr(0.173)))));
                write(f, chr(round(255*(1-i/255)*sqr(i/255-0.25)/sqr(0.25))));
                write(f, chr(round(255*(sqr(i/255-1)*sqr(i/255+1)))));
              end;
        end;
        line:=0;
        page:=0;
        for i:=0 to 577 do
          { Schleife über die zu Bild und Untergrund gehörenden Frames   }
          begin
            if i<512 then
              for k:=0 to 14 do
                write(f,chr(i shr 1))
            else
              for k:=0 to 14 do
                write(f,chr(0));
            ems_map(image_handle,page,image_page);
            for k:=0 to 384 do
              begin
                ch:=trunc(image_ptr^[line,k] /g *255);
                if ch>255 then ch:=255;
                write(f,chr(ch));
              end;
            inc(line);
            if line>20 then
              begin
                line:=0;
                inc(page);
                ems_map(image_handle,page,image_page);
              end;
          end;
      end;
    close(f);
    writeln(' Image gesichert.');
  end;

function   ccd_compute_bgnd(level, breite:integer) : integer;
  var i, j, k  : integer;
      sum      : double;
      count    : longint;
  begin
    sum:=0;
    count:=0;
    for i:=0 to 27 do
      { Schleife über die zum Bild gehörenden EMS-Frames             }
      begin
        ems_map(image_handle,i,image_page);
        for j:=0 to 20 do
          for k:=0 to 384 do
            if abs(image_ptr^[j,k]-level)<=breite then
              begin
                sum:=sum+image_ptr^[j,k];
                inc(count);
              end;
      end;
    ccd_compute_bgnd:=round(sum/count);
  end;

procedure  ccd_sub_bgnd(level:integer);
  var i, j, k  : integer;
  begin
    for i:=0 to 27 do
      { Schleife über die zum Bild gehörenden EMS-Frames             }
      begin
        ems_map(image_handle,i,image_page);
        for j:=0 to 20 do
          for k:=0 to 384 do
            dec(image_ptr^[j,k],level);
      end;
  end;

procedure  show_image;
  var i, j, k, l  : integer;
      page  : integer;
      line  : integer;
      c     : char;

  function pix_color(count:integer) : integer;
    var color : integer;
    begin
      color:=0;
      if count>1 then color:=8;
      if count>100 then color:=1;
      if count>500 then color:=2;
      if count>1000 then color:=9;
      if count>1400 then color:=10;
      if count>2000 then color:=12;
      if count>3000 then color:=14;
      if count>5000 then color:=15;
      pix_color:=color;
    end;

  procedure image_lupe;
    const lupe_x : integer = 260;
          lupe_y : integer = 165;
    var i, j, k, l  : integer;
    begin
      c:=' ';
      repeat
        if c=chr($148) then
          if lupe_y>=50 then lupe_y:=lupe_y-50;
        if c=chr($14d) then
          if lupe_x<=477 then lupe_x:=lupe_x+50;
        if c=chr($14b) then
          if lupe_x>=50 then lupe_x:=lupe_x-50;
        if c=chr($150) then
          if lupe_y<=284 then lupe_y:=lupe_y+50;
        if c<>chr(0) then
          begin
            SetColor(White);
            SetWriteMode(XORPut);
            Rectangle(lupe_x,lupe_y,lupe_x+52,lupe_y+52);
            SetWriteMode(NormalPut);
            Rectangle(449,325,603,479);
            page:=lupe_x div 21;
            line:=lupe_x mod 21;
            ems_map(image_handle,page,image_page);
            for j:=0 to 50 do
              begin
                for i:=334 to 384 do
                  begin
                    for k:=0 to 2 do
                      for l:=0 to 2 do
                        PutPixel(3*j+k+450,478-3*i+1002-l,
                          pix_color(image_ptr^[line,i-lupe_y]));
                  end;
                inc(line);
                if line>20 then
                  begin
                    line:=0;
                    inc(page);
                    ems_map(image_handle,page,image_page);
                  end;
              end;
          end;
        repeat until keypressed;
        if c<>chr(0) then
          begin
            SetWriteMode(XORPut);
            Rectangle(lupe_x,lupe_y,lupe_x+52,lupe_y+52);
            SetWriteMode(NormalPut);
          end;
        c:=readkey;
      until c in [chr(27),'q',chr(13),'e','l'];
    end;

  procedure image_circle;
    const circ_x : integer = 260;
          circ_y : integer = 165;
          circ_r : integer = 50;
    var   s, st  : string;
    begin
      c:=' ';
      SetColor(White);
      SetTextStyle(DefaultFont,HorizDir,1);
      SetTextJustify(LeftText,BottomText);
      repeat
        if c=chr($148) then
          circ_y:=circ_y-10;
        if c=chr($14d) then
          circ_x:=circ_x+10;
        if c=chr($14b) then
          circ_x:=circ_x-10;
        if c=chr($150) then
          circ_y:=circ_y+10;
        if c='+' then
          circ_r:=circ_r+10;
        if c='-' then
          circ_r:=circ_r-10;
        if c<>chr(0) then
          begin
            SetColor(White);
            SetWriteMode(XORPut);
            Circle(circ_x,circ_y,circ_r);
            str(circ_x:6,st);
            str(circ_y:6,s);
            st:=st+s;
            str(circ_r:6,s);
            st:=st+s;
            OutTextXY(10,400,st);
          end;
        repeat until keypressed;
        if c<>chr(0) then
          begin
            SetWriteMode(XORPut);
            Circle(circ_x,circ_y,circ_r);
            SetWriteMode(NormalPut);
          end;
        c:=readkey;
      until c in [chr(27),'q',chr(13),'e','c'];
    end;

  begin
    vgainit;
    c:=' ';
    repeat
      SetColor(White);
      Rectangle(0,0,579,386);
      page:=0;
      line:=0;
      ems_map(image_handle,page,image_page);
      for j:=0 to 577 do
        begin
          for i:=0 to 384 do
            PutPixel(j+1,385-i,pix_color(image_ptr^[line,i]));
          inc(line);
          if line>20 then
            begin
              line:=0;
              inc(page);
              ems_map(image_handle,page,image_page);
            end;
        end;
      repeat until keypressed;
      c:=readkey;
      if c='c' then image_circle;
      if c='l' then image_lupe;
    until c in [chr(27),'q',chr(13),'e'];
    CloseGraph;
  end;

function   ccd_event_list (fn     : string;
                           limit  : integer ) : longint;
  var i, j     : integer;
      page     : integer;
      ix, jx   : double;
      charge   : longint;
      num      : integer;
      count    : longint;
      f        : text;
  procedure recursive_sum(i,j:integer; var ix,jx:double;
                          var sum:longint; var anz:integer);
    var line   : integer;
        charge : longint;
        is, js : double;
    begin
      ix:=i;
      jx:=j;
      sum:=0;
      line:=j-21*page;
      charge:=image_ptr^[line,i];
      if (charge>limit) and (anz<100) then
        begin
          sum:=charge;
          inc(anz);
          image_ptr^[line,i]:=0;
          if i<384 then
            begin
              recursive_sum(i+1,j,is,js,charge,anz);
              if charge>limit then
                begin
                  ix:=(ix*sum+is*charge)/(sum+charge);
                  jx:=(jx*sum+js*charge)/(sum+charge);
                  sum:=sum+charge;
                end;
            end;
          if i>0 then
            begin
              recursive_sum(i-1,j,is,js,charge,anz);
              if charge>limit then
                begin
                  ix:=(ix*sum+is*charge)/(sum+charge);
                  jx:=(jx*sum+js*charge)/(sum+charge);
                  sum:=sum+charge;
                end;
            end;
          if j<577 then
            begin
              if line=20 then
                begin
                  inc(page);
                  ems_map(image_handle,page,image_page);
                end;
              recursive_sum(i,j+1,is,js,charge,anz);
              if charge>limit then
                begin
                  ix:=(ix*sum+is*charge)/(sum+charge);
                  jx:=(jx*sum+js*charge)/(sum+charge);
                  sum:=sum+charge;
                end;
              if line=20 then
                begin
                  dec(page);
                  ems_map(image_handle,page,image_page);
                end;
            end;
        end;
    end;
  begin
    count:=0;
    {$I-}
    assign(f,fn);
    reset(f);
    if IOResult=0 then
      begin
        close(f);
        append(f);
      end
    else
      rewrite(f);
    {$I+}
    for j:=0 to 577 do
      begin
        page:=j div 21;
        ems_map(image_handle,page,image_page);
        for i:=0 to 384 do
          begin
            num:=0;
            recursive_sum(i,j,ix,jx,charge,num);
            if charge>limit then
              begin
                writeln(f,jx:10:3,ix:10:3,charge:8,num:8);
                inc(count);
              end;
          end;
      end;
    close(f);
    ccd_event_list:=count;
  end;

procedure  ccd_event_image (fn        : string;
                            fx, fy    : integer;
                            gauss_mod : boolean;
                            fak       : real);
  var i, j    : integer;
      c       : char;
      ix, jy  : double;
      i1, i2  : integer;
      j1, j2  : integer;
      page    : integer;
      line    : integer;
      pixel   : double;
      charge  : longint;
      ch, chg : double;
      num     : integer;
      f       : text;
  begin
    {$I-}
    assign(f,fn);
    reset(f);
    {$I+}
    if IOResult=0 then
      begin
        ccd_clear_image;
        while not(eof(f)) do
          begin
            read(f,c);
            if c='#' then
              begin
                write('*');
                readln(f);
              end
            else
              begin
                readln(f,jy,ix,charge,num);
                if gauss_mod then
                  begin
                    i1:=round(ix-2*fx); if i1<0 then i1:=0;
                    i2:=round(ix+2*fx); if i2>384 then i2:=384;
                    j1:=round(jy-2*fy); if j1<0 then j1:=0;
                    j2:=round(jy+2*fy); if j2>577 then j2:=577;
                  end
                else
                  begin
                    i1:=round(ix-(fx-1)/2); if i1<0 then i1:=0;
                    i2:=round(ix+(fx-1)/2); if i2>384 then i2:=384;
                    j1:=round(jy-(fy-1)/2); if j1<0 then j1:=0;
                    j2:=round(jy+(fy-1)/2); if j2>577 then j2:=577;
                  end;
                charge:=round(charge*fak/(i2-i1+1)/(j2-j1+1));
                for j:=j1 to j2 do
                  begin
                    page:=j div 21;
                    line:=j mod 21;
                    ems_map(image_handle,page,image_page);
                    if gauss_mod then
                      chg:=charge*exp(-sqr((j-jy)/fy));
                    for i:=i1 to i2 do
                      begin
                        if gauss_mod then
                          ch:=chg*exp(-sqr((i-ix)/fx))
                        else
                          ch:=charge;
                        pixel:=image_ptr^[line,i]+ch;
                        if pixel>32767 then pixel:=32767;
                        image_ptr^[line,i]:=round(pixel);
                      end;
                  end;
              end;
          end;
        writeln;
        writeln(' Image geladen.');
      end;
    {$I-}
    close(f);
    {$I+}
  end;

procedure  rad_spek(fn:string; x,y:double);
  var i, j, k : integer;
      phi  : integer;
      line : integer;
      page : integer;
      cnt  : array [0..500] of integer;
      spk  : array [0..500] of single;
      f    : text;
  begin
    for k:=0 to 500 do
      begin
        cnt[k]:=0;
        spk[k]:=0.0;
      end;
    page:=0;
    line:=0;
    ems_map(image_handle,page,image_page);
    for j:=0 to 577 do
      begin
        for i:=0 to 384 do
          begin
            k:=round(sqrt(sqr(j-x)+sqr(i-y)));
            if k<=500 then
              begin
                inc(cnt[k]);
                spk[k]:=spk[k]+round(image_ptr^[line,i]);
              end;
          end;
        inc(line);
        if line>20 then
          begin
            line:=0;
            inc(page);
            ems_map(image_handle,page,image_page);
          end;
      end;
    {$I-}
    assign(f,fn);
    rewrite(f);
    {$I+}
    if IOResult=0 then
      begin
        writeln(f,'CCD-Kamera');
        writeln(f,'Radialverteilung');
        writeln(f,500);
        writeln(f,0.0);
        writeln(f,1.0);
        for k:=0 to 500 do
          if cnt[k]>0 then
            writeln(f,spk[k]/cnt[k])
          else
            writeln(f,0.0);
      end
    else writeln('Schreibfehler beim Anlegen der Spektrendatei');
    close(f);
    writeln(' Radialspektrum geschrieben.');
  end;

procedure  free_ccd;
  begin
    ems_free(image_handle);
  end;

begin
  init_ems;
  writeln(free_ems_pages,' EMS-Seiten frei');
  image_page:=1;
  image_ptr:=ems_page_ptr(image_page);
  image_handle:=allocate_ems(28);
  writeln(' Bild 1     : ',image_handle,'    ',
          seg(image_ptr^),':',ofs(image_ptr^));
  writeln;
end.					

1:

uses Windows					

1:
2:
3:

function GetConsoleScreenBufferInfo(hConsoleOutput: THandle;
  var lpConsoleScreenBufferInfo: TConsoleScreenBufferInfo): BOOL; stdcall; external 'kernel32.dll';
function GetStdHandle(nStdHandle: DWORD): THandle; stdcall; external 'kernel32.dll';					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;


type
  TForm1 = class(TForm)
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{$INCLUDE ConsolHelp.pas}  // <-- HIER einfügen!!!

end.