Amiga ISO Collection/AmigaUtilCD2.iso/Programming/Pascal/HISOFTPASCAL2,0-1.DMS/in.adf/HSPascal/AmigaDemos/Init.pas

Pascal/Delphi Source File | 1992-05-20 | 12.1 KB | 383 lines

{--------------------------------------------------------------------------

                     HighSpeed Pascal for the Amiga

                   ROUTINES FOR DEMO INITIALIZATION

                  Programmed by Martin Eskildsen 1991

                  Copyright (c) 1991 by D-House I ApS
                         All rights reserved


  Version : Date (dd.mm.yy) : Comment
  -----------------------------------
    1.00 : 06.11.91 : First version
    1.01 : 16.12.91 : System unit names updated
    1.10 : 22.04.92 : Updated for new units, Wait() fixed

--------------------------------------------------------------------------}

unit Init;

INTERFACE

uses Exec, Intuition, Graphics, Amiga;

const
  ScrWidth  = 640;                  { Size of custom screen }
  ScrHeight = 200;                  { Should not be changed! }

function PrepareEnvironment(s : string) : boolean;
                                    { Prepare an environment for the demo }
procedure CloseDown;                { De-init environment }

procedure Inform(s : string);       { Write message }
procedure Message(s : string);      { Write message and wait for acknowledement }
procedure WaitMessageClose;         { Wait for msg. window close gadget }

function Panic(condition : boolean; s : string) : boolean;
                                    { Write panic message s if condition is }
                                    { TRUE and return condition as result }

procedure WaitClose(var w : pWindow);   { Wait for user to click window w's close gadget }
procedure EnableClose(var w : pWindow); { Enable Close messages }
procedure DisableClose(var w : pWindow);{ Disable Close messages }

procedure OpenOutputWindow;         { Create a standard demo window }
procedure CloseOutputWindow;        { Remove it again }
procedure ClearOutputWindow;        { Clear work area }

function CStrConstPtr(s : string) : pointer;
{ This makes s a "C" string, allocates a chunck of heap large enough for s
  to reside therein, puts s in the new memory and returns a pointer to it.
  Please note that the memory is never released again in the program's
  lifespan. This avoids global variables containing screen/window titles. }

function RetrieveStr(p : pointer) : string;
{ Pick a "C" string from memory pointed at by p and make it Pascal string }

function Max(a, b : integer) : integer;
function Min(a, b : integer) : integer;
procedure SwapMin(var a, b : integer);    { Make sure a <= b }

function LegalPosition(x, y : integer) : boolean; { Is (x,y) inside output? }

function Binary(s : string) : integer;  { Make binary value from s }
{ s can contain any character but only 0 and 1 are used for evauation }


PROCEDURE W(CH:CHAR);


var
  BaseScreen   : pScreen;
  TopOffset    : integer;           { First raster line usable by demo }
  OutputWinDef : tNewWindow;        { Definition of output window }
                                    { The variable is set up in the }
                                    { unit but made global so the user can }
                                    { alter it before calling }
                                    { OpenOutputWindow. }
  OutputWindow : pWindow;           { The actual output window }
  OutputTitle  : String;            { Output window's title }
  WorkArea     : record             { Actual usable area in window }
                   minX, maxX,
                   minY, maxY  : integer
                 end;

IMPLEMENTATION


PROCEDURE W(CH:CHAR); BEGIN WRITE(CH) END;


const
  IRev         = 0;                 { Required Intuition revision }
  GRev         = 0;                 { Required Graphics revision }
  Detail       = 0;
  Block        = 1;

var
  MsgWindow    : pWindow;           { The message window }
  FontInfo     : tTextAttr;

procedure CloseEnvironment;
var junk: Boolean;
begin
  CloseWindow(MsgWindow);                 { Remove the message window }
  {$ifdef WORKBENCH_2}
  junk :=
  {$endif}
  CloseScreen(BaseScreen);                { and the screen }
  CloseLibrary(pLibrary(IntuitionBase));  { Close Intuition }
  CloseLibrary(pLibrary(GfxBase))         { and Graphics }
end;

function PrepareEnvironment(s : string) : boolean;
label 1;                         { Disaster termination point }
var
  status        : boolean;       { TRUE = everything went ok }
  BaseScreenDef : tNewScreen;    { Record defining the custom screen }
  MsgWindowDef  : tNewWindow;    { Record defining the message window }

  procedure DefineStdOutputWindow;
  begin
    with OutputWinDef do begin
      LeftEdge    := 10;
      TopEdge     := TopOffset;
      Width       := ScrWidth - 2 * LeftEdge;
      Height      := ScrHeight - TopOffset - 5;
      DetailPen   := Detail;
      BlockPen    := Block;
      Title       := @OutputTitle[1];
      Flags       := WINDOWCLOSE or SMART_REFRESH or WINDOWDEPTH or NOCAREREFRESH;
      IDCMPflags  := CLOSEWINDOW_;
      Type_       := CUSTOMSCREEN;
      FirstGadget := NIL;
      CheckMark   := NIL;
      Screen      := BaseScreen;
      BitMap      := NIL;
      MinWidth    := Width;
      MinHeight   := Height;
      MaxWidth    := MinWidth;
      MaxHeight   := MaxHeight
    end;
    OutputTitle   := 'Output'#0;
    OutputWindow  := NIL
  end;

begin
  status := FALSE;
  TopOffset := 0;

  IntuitionBase := pIntuitionBase(OpenLibrary('intuition.library', IRev));
                                 { Note the typecast pIntuitionBase(... }
  if Panic(IntuitionBase = NIL, 'intuition.library could not be opened') then goto 1;

  GfxBase := pGfxBase(OpenLibrary('graphics.library', GRev));
  if Panic(GfxBase = NIL, 'graphics.library could not be opened') then goto 1;

  with FontInfo do begin
    ta_Name    := CStrConstPtr('topaz.font');
    ta_YSize   := TOPAZ_EIGHTY;
    ta_Style   := FS_NORMAL;
    ta_Flags   := FPF_ROMFONT
  end;

  with BaseScreenDef do begin
    LeftEdge   := 0;                { MUST be 0! }
    TopEdge    := 0;
    Width      := ScrWidth;
    Height     := ScrHeight;
    Depth      := 2;                { Two bit planes = four colors }
    DetailPen  := Detail;           { Color for details }
    BlockPen   := Block;            { and for blocks }
    ViewModes  := HIRES;            { High resolution }
    Type_      := CUSTOMSCREEN;     { Note the underscore '_' }
    Font       := @FontInfo;        { Use the normal Topaz font }
    DefaultTitle := CStrConstPtr('HighSpeed Pascal for the Amiga! Copyright (c) 1991 by D-House I ApS');
    Gadgets      := NIL;            { No gadgets }
    CustomBitMap := NIL             { No bitmap }
  end;
  BaseScreen := OpenScreen(@BaseScreenDef);  { Note the @ operator }
  if Panic(BaseScreen = NIL, 'Could not open demo screen') then begin
    CloseLibrary(pLibrary(IntuitionBase));   { No screen! Close libs and }
    CloseLibrary(pLibrary(GfxBase));         { get out of here! }
    goto 1
  end;

  with MsgWindowDef do begin
    LeftEdge      := 10;
    TopEdge       := 15;
    Width         := ScrWidth - 2 * LeftEdge;
    Height        := 28;
    DetailPen     := Detail;
    BlockPen      := Block;
    Title         := CStrConstPtr('Messages. Use the Close gadget to accept/continue');
    Flags         := WINDOWCLOSE or       { Add Close gadget and }
                     WINDOWDEPTH or       { depth arrangement gadgets }
                     SMART_REFRESH or     { Save window in RAM }
                     ACTIVATE or          { Activate it }
                     NOCAREREFRESH;       { Don't wanna hear of refreshes! }
    IDCMPFlags    := CLOSEWINDOW_;        { But of user-clicks on Close }
    Type_         := CUSTOMSCREEN;        { Put window in custom screen }
    FirstGadget   := NIL;                 { No gadgets attached }
    CheckMark     := NIL;                 { Same checkmark as usual }
    Screen        := BaseScreen;          { Use our own custom screen }
    BitMap        := NIL;                 { No bitmap }
    MinWidth      := Width;               { Dummies as we can't resize }
    MinHeight     := Height;              { this window }
    MaxWidth      := MinWidth;
    MaxHeight     := MinHeight
  end;
  MsgWindow := OpenWindow(@MsgWindowDef);
  if Panic(MsgWindow = NIL, 'Can not open message window') then begin
    CloseEnvironment;
    goto 1
  end;
  DisableClose(MsgWindow);                { See WindowDemo.pas for explanation }

  status := TRUE;       { No Gurus! (yet...) Announce it to the world }

  TopOffset := MsgWindowDef.TopEdge +  { Top of window plus }
               MsgWindowDef.Height  +  { window's height plus }
               10;                     { a margin }

  DefineStdOutputWindow;
  Message('Welcome to the ' + s + ' Demo!');

  1:                    { Where to go if the world turns against you }
  PrepareEnvironment := status
end;

procedure CloseDown;
begin
  if OutputWindow <> NIL then             { <> NIL = window still on screen }
    CloseOutputWindow;                    { so we close it }
  Message('That''s all folks!');
  CloseEnvironment
end;

procedure Inform(s : string);
begin
  while length(s) < 73 do s := s + ' ';   { Pad with spaces (simple, eh?) }
  s := copy(s, 1, 73);                    { Truncate string to 73 chars }
  with MsgWindow^ do begin
    Move_(RPort, 20, 20);                 { Put text at (20,20) }
    Text_(RPort, @s[1], length(s))        { Output it }
  end
end;

procedure WaitClose(var w : pWindow);              { Wait for the user to }
var dummy : longint;                               { click the Close gadget }
begin                                              { in window w }
  EnableClose(w);
  dummy := Wait(BitMask(w^.UserPort^.MP_SIGBIT));
  DisableClose(w)
end;

procedure EnableClose(var w : pWindow);
begin
  with w^ do IDCMPflags := IDCMPflags or CLOSEWINDOW_
end;

procedure DisableClose(var w : pWindow);
begin
  with w^ do IDCMPflags := IDCMPflags and not CLOSEWINDOW_
end;

procedure Message(s : string);
begin
  Inform(s);                              { Output message }
  WaitClose(MsgWindow)                    { Wait for Close }
end;

procedure WaitMessageClose;
begin
  WaitClose(MsgWindow)
end;

function Panic(condition : boolean; s : string) : boolean;
begin
  if condition then Message('Demo problem: ' + s + ' - terminating soon.');
  Panic := condition
end;

procedure OpenOutputWindow;
begin
  OutputTitle := OutputTitle + #0;        { Just to be sure }
  OutputWinDef.Title := @OutputTitle[1];
  OutputWindow := OpenWindow(@OutputWinDef);
  if Panic(OutputWindow = NIL, 'Can''t open output window') then begin
    CloseDown;
    halt(0)
  end;
  SetApen(OutputWindow^.RPort, 3);
  with OutputWindow^, WorkArea do begin
    minX := BorderLeft;
    minY := BorderTop;
    maxX := Width  - BorderRight;
    maxY := Height - BorderBottom
  end
end;

procedure CloseOutputWindow;
begin
  CloseWindow(OutputWindow);
  OutputWindow := NIL
end;

procedure ClearOutputWindow;
begin
  with WorkArea, OutputWindow^ do begin
    SetAPen(RPort, 0);
    RectFill(RPort, minX, minY, maxX, maxY);
    SetAPen(RPort, 3)
  end
end;

function CStrConstPtr(s : string) : pointer;
type a = packed array [0..255] of char;
var  p : ^a;
begin
  s := s + #0;                         { Make "C" string }
  getmem(p, length(s));                { Get some mem for it }
  move(s[1], p^, length(s));           { Move s into newly alloc'd mem }
  CStrConstPtr := p                    { Return the pointer }
end;

function RetrieveStr(p : pointer) : string;
type
  a = packed array [0..255] of char;
var
  i    : integer;
  sptr : ^a;
  s    : string;
begin
  sptr := p;
  s := '';
  i := 0;
  while sptr^[i] <> #0 do begin
    s := s + sptr^[i];
    inc(i)
  end;
  RetrieveStr := s
end;

function Max(a, b : integer) : integer;
begin
  if a > b then Max := a else Max := b
end;

function Min(a, b : integer) : integer;
begin
  if a < b then Min := a else Min := b
end;

procedure SwapMin(var a, b : integer);
var t : integer;
begin
  if a > b then begin
    t := a;
    a := b;
    b := t
  end
end;

function LegalPosition(x, y : integer) : boolean;
begin
  with WorkArea do LegalPosition := (x >= minX) and (x <= maxX) and
                                    (y >= minY) and (y <= maxY)
end;

function Binary(s : string) : integer;
var i, n : integer;
begin
  n := 0;
  for i := 1 to length(s) do
    if s[i] in ['0', '1'] then n := n*2 + ord(s[i]) - ord('0');
  Binary := n
end;

end.