home *** CD-ROM | disk | FTP | other *** search
/ AMIGA PD 1 / AMIGA-PD-1.iso / Programme_zum_Heft / Programmieren / Kurztests / PascalPCQ / Examples / Moire.p < prev    next >
Text File  |  1991-04-18  |  3KB  |  142 lines
  1. Program Moire;
  2.  
  3.     { This program just draws a Moire pattern in a window.
  4.       It uses a surprising breadth of functions, so it shows
  5.       off a bit of what PCQ can do.  And it works to boot. }
  6.  
  7. {$I "Include:Exec/Libraries.i"}
  8. {$I "Include:Exec/Interrupts.i"}
  9. {$I "Include:Exec/Ports.i"}
  10. {$I "Include:Intuition/Intuition.i"}
  11. {$I "Include:Graphics/Graphics.i"}
  12. {$I "Include:Graphics/Pens.i"}
  13.  
  14. var
  15.     w  : WindowPtr;
  16.     s  : Address;
  17.     m  : MessagePtr;
  18.  
  19. Function OpenTheScreen() : Boolean;
  20. var
  21.     ns : NewScreenPtr;
  22. begin
  23.     new(ns);
  24.     with ns^ do begin
  25.     LeftEdge := 0;
  26.     TopEdge  := 0;
  27.     Width    := 640;
  28.     Height   := 200;
  29.     Depth    := 2;
  30.     DetailPen := 3;
  31.     BlockPen  := 2;
  32.     ViewModes := 32768;
  33.     SType     := CUSTOMSCREEN_f;
  34.     Font      := nil;
  35.     DefaultTitle := "Close the Window to End This Demonstration";
  36.     Gadgets   := nil;
  37.     CustomBitMap := nil;
  38.     end;
  39.     s := OpenScreen(ns);
  40.     dispose(ns);
  41.     OpenTheScreen := s <> nil;
  42. end;
  43.  
  44. Function OpenTheWindow() : Boolean;
  45. var
  46.     nw : NewWindowPtr;
  47. begin
  48.     new(nw);
  49.     with nw^ do begin
  50.     LeftEdge := 20;
  51.     TopEdge := 50;
  52.     Width := 336;
  53.     Height := 100;
  54.  
  55.     DetailPen := -1;
  56.     BlockPen  := -1;
  57.     IDCMPFlags := CLOSEWINDOW_f;
  58.     Flags := WINDOWSIZING + WINDOWDRAG + WINDOWDEPTH +
  59.          WINDOWCLOSE + SMART_REFRESH + ACTIVATE;
  60.     FirstGadget := nil;
  61.     CheckMark := nil;
  62.     Title := "Feel Free to Re-Size the Window";
  63.     Screen := s;
  64.     BitMap := nil;
  65.     MinWidth := 50;
  66.     MaxWidth := -1;
  67.     MinHeight := 20;
  68.     MaxHeight := -1;
  69.     WType := CUSTOMSCREEN_f;
  70.     end;
  71.  
  72.     w := OpenWindow(nw);
  73.     dispose(nw);
  74.     OpenTheWindow := w <> nil;
  75. end;
  76.  
  77. Procedure DoDrawing(RP : RastPortPtr);
  78. var
  79.     x  : Short;
  80.     Pen : Byte;
  81.     Stop : Short;
  82. begin
  83.     Pen := 1;
  84.     while true do begin
  85.     with w^ do begin
  86.         x := 0;
  87.         while x < Pred(Width - BorderRight - BorderLeft) do begin
  88.         Stop := Pred(Width - BorderRight);
  89.         SetAPen(RP, Pen);
  90.         Move(RP, Succ(x + BorderLeft), BorderTop);
  91.         Draw(RP, Stop - x, Pred(Height - BorderBottom));
  92.         Pen := (Pen + 1) mod 4;
  93.         Inc(x);
  94.         end;
  95.         m := GetMsg(UserPort);
  96.         if m <> Nil then
  97.         return;
  98.         x := 0;
  99.         while x < Pred(Height - BorderBottom - BorderTop) do begin
  100.         Stop := Pred(Height - BorderBottom);
  101.         SetAPen(RP, Pen);
  102.         Move(RP, Pred(Width - BorderRight), Succ(x + BorderTop));
  103.         Draw(RP, Succ(BorderLeft), Stop - x);
  104.         Pen := (Pen + 1) mod 4;
  105.         Inc(x);
  106.         end;
  107.         m := GetMsg(UserPort);
  108.         if m <> Nil then
  109.         return;
  110.     end;
  111.     end;
  112. end;
  113.  
  114. begin
  115.     { Note that the startup code of all PCQ programs depends on
  116.       Intuition, so if we got to this point Intuition must be
  117.       open, so the run time library just uses the pointer that
  118.       the startup code created.  Same with DOS, although we don't
  119.       use that here. }
  120.  
  121.     GfxBase := OpenLibrary("graphics.library", 0);
  122.     if GfxBase <> nil then begin
  123.     if OpenTheScreen() then begin
  124.         if OpenTheWindow() then begin
  125.         DoDrawing(w^.RPort);
  126.         Forbid;
  127.         repeat
  128.             m := GetMsg(w^.UserPort);
  129.         until m = nil;
  130.         CloseWindow(w);
  131.         Permit;
  132.         end else
  133.         writeln('Could not open the window');
  134.         CloseScreen(s);
  135.     end else
  136.         writeln('Could not open the screen.');
  137.     CloseLibrary(GfxBase);
  138.     end else
  139.     writeln('Could not open graphics.library');
  140. end.
  141.  
  142.