UNIT sys {$project vt}
{ Betriebssystemnahe Funktionen zum Programm VideoText }

INTERFACE;

TYPE Str80 = String[80];

FUNCTION abbruch_test: Boolean;
FUNCTION readkey: Char;
FUNCTION waitkey: Char;
FUNCTION ja_nein: Boolean;
FUNCTION fileselect(was_los: str80; speichern: boolean;
                                   var selected: str80): Boolean;
PROCEDURE telltime(VAR day,min,tic: Long);
PROCEDURE stretch_line(zeile, sp0, sp1: Integer);
FUNCTION bitmapzeile(plane,line: Integer): Ptr;
PROCEDURE busy_pointer;
PROCEDURE normal_pointer;
PROCEDURE desaster(meldung: Str80);
PROCEDURE sysinit(version: Str);
PROCEDURE sysclean;

VAR Con: Ptr;  { darf nicht vom ExitServer geschlossen werden, komisch }

{ ---------------------------------------------------------------------- }

IMPLEMENTATION;

{$ opt b- }
{$ incl "exec.lib", "intuition.lib", "graphics.lib" }
{$ incl "diskfont.lib", "dos.lib", "req.lib" }

TYPE WordArr36 = ARRAY [1..36] OF Word;

VAR NeuerScreen: NewScreen;  STATIC;
    MyScreen: ^Screen;
    titel: Str80;  STATIC;
    NeuesWindow: NewWindow;  STATIC;
    myprocess: p_Process;
    MyWindow,oldwindowptr: ^Window;
    Menue1: Menu; STATIC;
    Mi: Array[1..5] of MenuItem; STATIC;
    MiT: Array[1..5] of IntuiText; STATIC;
    breite,hoehe: integer;
    topazAttr,teleAttr: TextAttr;
    MyFont: ^TextFont;
    BusyPointerData: ^WordArr36;
    { für die req.library: }
    MyFileReq: ReqFileRequester; STATIC;
    pfad: Array[0..DSIZE] of Char; STATIC;
    name: Array[0..FCHARS] of Char; STATIC;
    pfadname: Array[-DSIZE..FCHARS] of Char; STATIC;

FUNCTION abbruch_test{: Boolean};
{ Schaut, ob das Menue 'Quit' angewählt wurde. }
{ Aufruf am besten in der Form: "ende := ende OR abbruch_test", wobei }
{ <ende> eine globale Variable ist }
VAR Msg: ^IntuiMessage;
    item,men,menitem,subitem: Word;
    item_address: ^MenuItem;
BEGIN
  abbruch_test := False;
  Msg := Get_Msg(MyWindow^.UserPort);
  IF Msg <> Nil THEN BEGIN
    IF Msg^.class = MENUPICK THEN BEGIN
      item := Msg^.Code;
      WHILE item<>MENUNULL DO BEGIN
        { item nach Menue, Menuepunkt und Untermenue aufschlüsseln }
        men:=item AND %00011111;
        menitem:=(item SHR 5) AND %00111111;
        subitem:=(item SHR 11) AND %00011111;
        IF (men=0) AND (menitem=0) THEN
          abbruch_test := True;
        item_address := ItemAddress(^Menue1,item);
        item := item_address^.NextSelect;
      END;
    END;
    Reply_Msg(Msg);
  END;
END;

FUNCTION readkey{: Char};
begin
  readkey := ReadCon(Con);
end;

FUNCTION waitkey{: Char};
var taste: char;
    sig: long;
begin
  repeat
    sig := wait(-1);
    taste := ReadCon(Con);
  until taste <> chr(0);
  waitkey := taste;
end;

FUNCTION ja_nein{: Boolean};
var ch: char;
begin
  write(' (J/N)?  ');
  repeat
    delay(2); write(#8' '#8);
    ch := waitkey;
    if (ord(ch) mod 128)>31 then write(ch) else write(' ');
  until ch in ['j', 'J', 'n', 'N']
  ja_nein := ch in ['j', 'J'];
end;

FUNCTION fileselect{(was_los: str80; speichern: boolean;
                                   var selected: str80): Boolean};
{ benutzt, wenn vorhanden, den Filerequester der req.library }
VAR i,p,l: Integer;
BEGIN
  fileselect := FALSE;
  IF ReqBase=Nil THEN BEGIN
    Write(was_los,#155' p: '); { Cursor sichtbar machen! }
    IF NOT EmptyLn(input) THEN BEGIN
      ReadLn(selected); fileselect := TRUE;
    END;
  END ELSE BEGIN
    l := length(selected);
    p := 0;
    { selected in pfad und name spalten }
    for i := 1 to l do
      if (selected[i]='/') or (selected[i]=':') then p := i;
    if p=0 then pfad := '' else pfad := copy(selected,1,p);
    if p=l then name := '' else name := copy(selected,p+1,l-p);
    with MyFileReq do begin
      VersionNumber := REQVERSION;
      Title := was_los;
      PathName := pfadname;   { Str-Zeiger auf meinen Puffer setzen }
      Dir := pfad;
      _File := name;
      WindowLeftEdge := 128;
      WindowTopEdge := 25;
      Flags := FRQABSOLUTEXYM;
      if speichern then
        Flags := Flags or FRQSAVINGM
      else
        Flags := Flags or FRQLOADINGM;
      filenamescolor := 6;
      dirnamescolor := 3;
      devicenamescolor := 6;
      detailcolor := 1;
      blockcolor := 0;
      gadgettextcolor := 1;
      textmessagecolor := 6;
      stringnamecolor := 6;
      stringgadgetcolor := 4;
      boxbordercolor := 6;
      gadgetboxcolor := 4;
    end;
    if FileRequester(^MyFileReq) then begin
      selected := pfadname;
      fileselect := true;
    end;
  END;
END;

PROCEDURE telltime{(VAR day,min,tic: Long)};
VAR time: DateStamp;
BEGIN
  IF _DateStamp(^time)<>Nil THEN BEGIN
    day := time.ds_Days;
    min := time.ds_Minute;
    tic := time.ds_Tick;
  END;
END;

PROCEDURE stretch_line{(zeile, sp0, sp1: Integer)};
{ Streckt eine Textzeile am Bildschirm von sp0 bis einschließlich sp1 auf }
{ doppelte Höhe. }
{ Zeilen und Spalten werden, wie bei GotoXY üblich, ab 1 gezählt! }
VAR charx,chary,i,y0,x0,breite: Integer;
BEGIN
  charx := MyWindow^.RPort^.TxWidth;
  chary := MyWindow^.RPort^.TxHeight;
  y0 := (zeile-1)*chary;
  x0 := (sp0-1)*charx; breite := (sp1-sp0+1)*charx;
  FOR i := chary-1 DOWNTO 0 DO BEGIN
    ClipBlit(MyWindow^.RPort,x0,y0+i,MyWindow^.RPort,x0,y0+2*i,breite,1,$C0);
    ClipBlit(MyWindow^.RPort,x0,y0+i,MyWindow^.RPort,x0,y0+2*i+1,breite,1,$C0);
  END;
END;

FUNCTION bitmapzeile{(plane,line: Integer): Ptr};
VAR map: p_BitMap;
    y0: Integer;
BEGIN
  map := MyWindow^.RPort^.BitMap;
  y0 := MyWindow^.TopEdge + MyWindow^.BorderTop;
  bitmapzeile := Ptr(Long(map^.Planes[plane]) + (y0+line)*map^.BytesPerRow);
END;

PROCEDURE busy_pointer;
BEGIN
  IF BusyPointerData<>Nil THEN
    SetPointer(MyWindow, BusyPointerData, 16, 16, -6, 0);
END;

PROCEDURE normal_pointer;
BEGIN
  ClearPointer(MyWindow);
END;

PROCEDURE desaster{(meldung: Str80)};
{ erzeugt einen Alert }
var egal: boolean;
    buf: string;
    xpos: integer;
begin
  xpos := 320 - 4*length(meldung);
  buf := '   '+meldung;
  buf[1] := chr(Hi(xpos)); buf[2] := chr(Lo(xpos));
  buf[3] := chr(18);
  buf [length(meldung)+5] := chr(0);
  egal := DisplayAlert(RECOVERY_ALERT,buf,32);
end;

PROCEDURE sysinit{(version: Str)};
const charx = 8;  { für Menuetexte }
      chary = 8;
var i: integer;
    flags, cflags, breit: Word;
    egal: long;
begin
  { Zuerst Zeiger für den zugehörigen ExitServer initialisieren: }
  IntuitionBase := Nil; GfxBase := Nil; DiskFontBase := Nil; ReqBase := Nil;
  MyScreen := Nil; MyWindow := Nil; MyFont := Nil; oldwindowptr := Nil;
  BusyPointerData := Nil;
  { Filerequester-Struktur initialisieren (in C wäre das nicht nötig!), }
  { muß an dieser Stelle geschehen, damit PurgeFiles nicht abstürzt! }
  for i := 0 to SizeOf(ReqFileRequester)-1 do
    Mem[Long(^MyFileReq)+i] := 0;
  { Libraries etc. öffnen: }
  IntuitionBase := OpenLibrary('intuition.library',0);
  GfxBase := OpenLibrary('graphics.library',0);
  DiskFontBase := OpenLibrary('diskfont.library',0);
  ReqBase := OpenLibrary('req.library',0);
  if IntuitionBase=Nil then Error('Can''t open intuition.library!');
  if GfxBase=Nil then Error('Can''t open graphics.library!');
  if DiskfontBase=Nil then desaster('Can''t open diskfont.library !!!');
  {if ReqBase=Nil then  desaster('Can''t open req.library !!!');}
  { Screen: }
  breite := 640;
  hoehe := 256;
  titel := copy(version,7,length(version)-6);
  topazAttr := TextAttr('topaz.font',8,FS_NORMAL,FPF_ROMFONT);
  NeuerScreen := NewScreen(0,0,breite,hoehe,3,6,4,HIRES or GENLOCK_VIDEO,
    CUSTOMSCREEN,^topazAttr,titel,Nil,Nil);
  MyScreen := OpenScreen(^NeuerScreen);
  for i := 0 to 7 do
    SetRGB4(^MyScreen^.ViewPort, i, 15*( i        and 1),
                                    15*((i div 2) and 1),
                                    15*((i div 4) and 1));
  { Fenster und Menue: }
  NeuesWindow := NewWindow(0,16,breite,hoehe-16,0,7, MENUPICK,
           ACTIVATE or BORDERLESS or BACKDROP,
           Nil,Nil,Nil,MyScreen,Nil,170,100,breite,hoehe,CUSTOMSCREEN);
  MyWindow := OpenWindow(^NeuesWindow);
  Menue1 := Menu(Nil,10,0,8*charx,0,MENUENABLED,'Projekt',^Mi[1],0,0,0,0);
  { besonders häufige Flagkombinationen: }
  Flags := ITEMTEXT or ITEMENABLED or HIGHCOMP; CFlags := Flags or COMMSEQ;
  { Menueeinträge und Texte: }
  { Projekt: Quit }
  breit := (4+3)*charx + COMMWIDTH;
  for i := 1 to 1 do
    Mi[i] := MenuItem(Nil,0,(chary+2)*(i-1),breit,chary+2,CFlags,
                   0,^MiT[i],Nil,chr(0),Nil,MENUNULL);
  Mi[1].NextItem := Nil;    Mi[1].Command := 'Q';
  MiT[1] := IntuiText(0,7,JAM1,5,1,Nil, 'Quit',Nil);
  if not SetMenuStrip(MyWindow,^Menue1) then
    Error('Cannot install the menues - damn!');
  { Font: }
  teleAttr := TextAttr('videotext.font',9,FS_NORMAL,FPF_DISKFONT);
  if DiskFontBase<>Nil then
    MyFont := OpenDiskFont(^teleAttr);
  if MyFont<>Nil then
    egal := SetFont(MyWindow^.RPort,MyFont)
  else
    desaster('Can''t open videotext.font !!!');
  Con := OpenConsole(MyWindow);
  SetStdIO(Con);
  BusyPointerData := Ptr(AllocMem(SizeOf(WordArr36),MEMF_CHIP));
  IF BusyPointerData <> Nil THEN
    BusyPointerData^ := WordArr36(
      $0000,$0000,
      $0400,$07C0,$0000,$07C0,$0100,$0380,$0000,$07E0,
      $07C0,$1FF8,$1FF0,$3FEC,$3FF8,$7FDE,$3FF8,$7FBE,
      $7FFC,$FF7F,$7EFC,$FFFF,$7FFC,$FFFF,$3FF8,$7FFE,
      $3FF8,$7FFE,$1FF0,$3FFC,$07C0,$1FF8,$0000,$07E0,
      $0000,$0000
    );
  { meine Task finden und System Requests auf meinen Screen umleiten }
  myprocess := ptr(FindTask(Nil));
  oldwindowptr := myprocess^.pr_WindowPtr;
  myprocess^.pr_WindowPtr := MyWindow;
end;

PROCEDURE sysclean;
begin
  if oldwindowptr<>Nil then myprocess^.pr_WindowPtr := oldwindowptr;
  if ReqBase<>Nil then begin
    PurgeFiles(^MyFileReq); CloseLibrary(ReqBase); end;
  if MyWindow<>Nil then begin
    ClearMenuStrip(MyWindow);
    CloseWindow(MyWindow);
  end;
  if MyScreen<>Nil then if CloseScreen(MyScreen) then;
  if MyFont<>Nil then CloseFont(MyFont);
  if IntuitionBase<>Nil then CloseLibrary(IntuitionBase);
  if GfxBase<>Nil then CloseLibrary(GfxBase);
  if DiskFontBase<>Nil then CloseLibrary(DiskFontBase);
  IF BusyPointerData <> Nil THEN FreeMem(Ptr(BusyPointerData),SizeOf(WordArr36));
  { festhalten, daß alles geschlossen ist: }
  ReqBase := Nil;
  MyWindow := Nil;
  MyScreen := Nil;
  MyFont := Nil;
  IntuitionBase := Nil;
  GfxBase := Nil;
  DiskFontBase := Nil;
  BusyPointerData := Nil;
end;

BEGIN  { Initialisierungsteil }
END.