home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / M2V11-1.LHA / modula / examples / src / DoubleBuffer.mod < prev    next >
Encoding:
Text File  |  1994-10-03  |  19.6 KB  |  672 lines
  1. (* Converted from example in 3.1 native developers update *)
  2. MODULE DoubleBuffer ;
  3.  
  4. IMPORT
  5.       S := SYSTEM,
  6.       D := Dos{37},
  7.    SLib := StdLib,
  8.       E := Exec,
  9.       U := Utility,
  10.      GT := GadTools{39},
  11.     MID := ModeID,
  12.       G := Graphics{39},
  13.       I := Intuition{39} ;
  14.  
  15. (*----------------------------------------------------------------------------*)
  16.  
  17. (* Some constants to handle the rendering of the animated face *)
  18. CONST
  19.   BM_WIDTH    = 120 ;
  20.   BM_HEIGHT    =  60 ;
  21.   BM_DEPTH    =   2 ;
  22.  
  23. (* Odd numbers to give a non-repeating bounce *)
  24.   CONTROLSC_TOP     = 191 ;
  25.   SC_ID         = MID.HIRES_KEY ;
  26.  
  27. (* User interface constants and variables *)
  28.  
  29.   GAD_HORIZ    = 1 ;
  30.   GAD_VERT    = 2 ;
  31.  
  32.   MENU_RUN    = 1 ;
  33.   MENU_STEP    = 2 ;
  34.   MENU_QUIT    = 3 ;
  35.   MENU_HSLOW    = 4 ;
  36.   MENU_HFAST    = 5 ;
  37.   MENU_VSLOW    = 6 ;
  38.   MENU_VFAST    = 7 ;
  39.  
  40.   OK_REDRAW = 1    ; (* Buffer fully detached, ready for redraw *)
  41.   OK_SWAPIN = 2 ; (* Buffer redrawn, ready for swap-in         *)
  42.  
  43. (*----------------------------------------------------------------------------*)
  44.  
  45. VAR
  46.   Topaz80    : G.TextAttr ;
  47.   vctags    : ARRAY [0..1] OF U.TagItem ;
  48.   pens        : ARRAY [0..12] OF CARDINAL ;
  49.   demomenu    : ARRAY [0..11] OF GT.NewMenu ;
  50.  
  51.   canvassc    : I.ScreenPtr ;
  52.   controlsc    : I.ScreenPtr ;
  53.   controlwin    : I.WindowPtr ;
  54.   canvaswin    : I.WindowPtr ;
  55.   glist        : I.GadgetPtr ;
  56.   horizgad    : I.GadgetPtr ;
  57.   vertgad    : I.GadgetPtr ;
  58.   menu        : I.MenuPtr   ;
  59.   canvasvi    : S.ADDRESS   ;
  60.   controlvi    : S.ADDRESS   ;
  61.  
  62.   dbufport    : E.MsgPortPtr ;
  63.   userport    : E.MsgPortPtr ;
  64.  
  65.   status    : ARRAY [ 0..1 ] OF LONGINT ;
  66.   rport        : ARRAY [ 0..1 ] OF G.RastPort ;
  67.   count        : LONGINT ;
  68.   face        : G.BitMapPtr ;
  69.  
  70.   scbuf        : ARRAY [0..1] OF I.ScreenBufferPtr ;
  71.   prevx        : ARRAY [0..1] OF LONGINT ;
  72.   prevy        : ARRAY [0..1] OF LONGINT ;
  73.  
  74.   buf_current, buf_nextdraw, buf_nextswap : LONGINT ;
  75.   x, y, xstep, xdir, ystep, ydir : LONGINT ;
  76.  
  77. (*----------------------------------------------------------------------------*)
  78.  
  79. PROCEDURE init_all( ) : S.STRING ; FORWARD ;
  80. PROCEDURE error_exit( errorstring : S.STRING ) ; FORWARD ;
  81. PROCEDURE createAllGadgets( VAR glistptr : I.GadgetPtr ;
  82.                       vi : S.ADDRESS ) : I.GadgetPtr ; FORWARD ;
  83. PROCEDURE handleIntuiMessage( imsg : I.IntuiMessagePtr ) : BOOLEAN ; FORWARD ;
  84. PROCEDURE handleDBufMessage( dbmsg : E.MessagePtr ) ; FORWARD ;
  85. PROCEDURE handleBufferSwap( ) : LONGINT ; FORWARD ;
  86. PROCEDURE makeImageBM( ) : G.BitMapPtr ; FORWARD ;
  87. PROCEDURE CloseWindowSafely( win : I.WindowPtr ) ; FORWARD ;
  88. PROCEDURE StripIntuiMessages( mp : E.MsgPortPtr ; win : I.WindowPtr ); FORWARD ;
  89.  
  90. (*----------------------------------------------------------------------------*)
  91.  
  92. PROCEDURE main( ) ;
  93.   VAR
  94.     errorstring : S.STRING ;
  95.     sigs    : LONGSET ;
  96.     terminated    : BOOLEAN ;
  97.     imsg    : I.IntuiMessagePtr ;
  98.     dbmsg    : E.MessagePtr ;
  99.     held_off    : LONGINT ;
  100. BEGIN
  101.   terminated := FALSE ;
  102.   (* Let's get everything initialized *)
  103.   errorstring := init_all( ) ;
  104.   IF errorstring # NIL THEN error_exit( errorstring ) END ;
  105.  
  106.   count        :=  0  ;
  107.   buf_current    :=  0  ;
  108.   buf_nextdraw    :=  1  ;
  109.   buf_nextswap    :=  1  ;
  110.   sigs        := { } ;
  111.  
  112.   WHILE ~terminated DO
  113.     (* Check for and handle any IntuiMessages *)
  114.     IF userport^.mp_SigBit IN sigs THEN
  115.       LOOP
  116.     imsg := GT.GT_GetIMsg( userport ) ;
  117.     IF imsg = NIL THEN EXIT END ;
  118.     terminated := terminated OR handleIntuiMessage( imsg ) ;
  119.     GT.GT_ReplyIMsg( imsg ) ;
  120.       END ;
  121.     END ;
  122.  
  123.     (* Check for and handle any double-buffering messages.  *)
  124.     (* Note that double-buffering messages are "replied" to *)
  125.     (* us, so we don't want to reply them to anyone.        *)
  126.  
  127.     IF dbufport^.mp_SigBit IN sigs THEN
  128.       LOOP
  129.     dbmsg := E.GetMsg( dbufport ) ;
  130.     IF dbmsg = NIL THEN EXIT END ;
  131.     handleDBufMessage( dbmsg );
  132.       END ;
  133.     END ;
  134.  
  135.     IF ~terminated THEN
  136.       held_off := 0;
  137.       (* Only handle swapping buffers if count is non-zero *)
  138.       IF count # 0 THEN held_off := handleBufferSwap( ) END ;
  139.     IF held_off # 0 THEN
  140.       (* If were held-off at ChangeScreenBuffer() time, then we    *)
  141.       (* need to try ChangeScreenBuffer() again, without awaiting    *)
  142.       (* a signal.  We WaitTOF() to avoid busy-looping.        *)
  143.       G.WaitTOF( ) ;
  144.     ELSE
  145.       (* If we were not held-off, then we're all done        *)
  146.       (* with what we have to do.  We'll have no work to do        *)
  147.       (* until some kind of signal arrives.  This will normally    *)
  148.       (* be the arrival of the dbi_SafeMessage from the ROM        *)
  149.       (* double-buffering routines, but it might also be an        *)
  150.       (* IntuiMessage.                        *)
  151.       sigs := E.Wait( {dbufport^.mp_SigBit,userport^.mp_SigBit} );
  152.     END ;
  153.       END ;
  154.     END ;
  155.  
  156.     error_exit( NIL ) ;
  157. END main ;
  158.  
  159. (*----------------------------------------------------------------------------*)
  160.  
  161. (* Handle the rendering and swapping of the buffers *)
  162.  
  163. PROCEDURE handleBufferSwap( ) : LONGINT ;
  164.   VAR held_off : LONGINT ;
  165. BEGIN
  166.  
  167.   held_off := 0 ;
  168.  
  169.   (* 'buf_nextdraw' is the next buffer to draw into.            *)
  170.   (* The buffer is ready for drawing when we've received the        *)
  171.   (* dbi_SafeMessage for that buffer.  Our routine to handle        *)
  172.   (* messaging from the double-buffering functions sets the        *)
  173.   (* OK_REDRAW flag when this message has appeared.            *)
  174.   (*                                    *)
  175.   (* Here, we set the OK_SWAPIN flag after we've redrawn        *)
  176.   (* the imagery, since the buffer is ready to be swapped in.        *)
  177.   (* We clear the OK_REDRAW flag, since we're done with redrawing    *)
  178.  
  179.   IF status[ buf_nextdraw ] = OK_REDRAW THEN
  180.     INC( x , xstep*xdir ) ;
  181.     IF x < 0 THEN x := 0 ; xdir := 1;
  182.     ELSIF x > canvassc^.Width - BM_WIDTH THEN
  183.       x := canvassc^.Width - BM_WIDTH - 1 ; xdir := -1
  184.     END ;
  185.     INC( y , ystep*ydir ) ;
  186.     IF y < canvassc^.BarLayer^.Height THEN
  187.       y := canvassc^.BarLayer^.Height ; ydir := 1
  188.     ELSIF y >= CONTROLSC_TOP - BM_HEIGHT THEN
  189.       y := CONTROLSC_TOP - BM_HEIGHT - 1 ; ydir := -1
  190.     END ;
  191.  
  192.     G.SetAPen( S.ADR( rport[ buf_nextdraw ] ) , 0 );
  193.     G.RectFill( S.ADR( rport[ buf_nextdraw ] ) ,
  194.         prevx[ buf_nextdraw ], prevy[ buf_nextdraw ],
  195.         prevx[ buf_nextdraw ] + BM_WIDTH - 1, prevy[ buf_nextdraw ]
  196.         + BM_HEIGHT - 1 ) ;
  197.     prevx[buf_nextdraw] := x ;
  198.     prevy[buf_nextdraw] := y ;
  199.  
  200.     G.BltBitMapRastPort( face, 0, 0, S.ADR( rport[ buf_nextdraw ] ), x, y,
  201.         BM_WIDTH, BM_HEIGHT, 0C0H );
  202.  
  203.     G.WaitBlit( ) ; (* Gots to let the BBMRP finish *)
  204.  
  205.     status[ buf_nextdraw ] := OK_SWAPIN;
  206.  
  207.     (* Toggle which the next buffer to draw is.          *)
  208.     (* If you're using multiple ( >2 ) buffering, you      *)
  209.     (* would use                      *)
  210.     (*                              *)
  211.     (*   buf_nextdraw = ( buf_nextdraw+1 ) % NUMBUFFERS ; *)
  212.  
  213.     buf_nextdraw := ORD( ~VAL(BOOLEAN,buf_nextdraw) ) ;
  214.   END ;
  215.  
  216.   (* Let's make sure that the next frame is rendered before we swap... *)
  217.  
  218.   IF status[buf_nextswap] = OK_SWAPIN THEN
  219.  
  220.     scbuf[buf_nextswap]^.sb_DBufInfo^.dbi_SafeMessage.mn_ReplyPort:= dbufport;
  221.  
  222.     IF I.ChangeScreenBuffer( canvassc, scbuf[ buf_nextswap ] ) # 0 THEN
  223.       status[buf_nextswap] := 0 ;
  224.       buf_current := buf_nextswap ;
  225.  
  226.       (* Toggle which the next buffer to swap in is.        *)
  227.       (* If you're using multiple ( >2 ) buffering, you        *)
  228.       (* would use                        *)
  229.       (*                            *)
  230.       (* buf_nextswap = ( buf_nextswap+1 ) % NUMBUFFERS;    *)
  231.  
  232.       buf_nextswap := ORD( ~VAL(BOOLEAN,buf_nextswap) ) ;
  233.       DEC( count ) ;
  234.     ELSE held_off := 1 ;
  235.     END ;
  236.   END ;
  237.   RETURN( held_off )
  238. END handleBufferSwap ;
  239.  
  240. (*----------------------------------------------------------------------------*)
  241.  
  242. (* Handle Intuition messages *)
  243.  
  244. PROCEDURE handleIntuiMessage( imsg : I.IntuiMessagePtr ) : BOOLEAN ;
  245.   VAR
  246.     code    : CARDINAL      ;
  247.     terminated    : BOOLEAN       ;
  248.     item    : I.MenuItemPtr ;
  249. BEGIN
  250.   terminated := FALSE ;
  251.   code := imsg^.Code ;
  252.   IF    imsg^.Class = I.IDCMP_GADGETDOWN THEN
  253.   ELSIF imsg^.Class = I.IDCMP_GADGETUP   THEN
  254.   ELSIF imsg^.Class = I.IDCMP_MOUSEMOVE  THEN
  255.     CASE imsg^.IAddress(I.GadgetPtr)^.GadgetID OF
  256.     | GAD_HORIZ: xstep := code ;
  257.     | GAD_VERT : ystep := code ;
  258.     END ;
  259.  
  260.   ELSIF imsg^.Class = I.IDCMP_VANILLAKEY THEN
  261.     CASE CHR( code ) OF
  262.     | 'S' , 's': count :=  1 ;
  263.     | 'R' , 'r': count := -1 ;
  264.     | 'Q' , 'q': count :=  0 ; terminated := TRUE ;
  265.     ELSE
  266.     END ;
  267.  
  268.   ELSIF imsg^.Class = I.IDCMP_MENUPICK THEN
  269.     WHILE code # I.MENUNULL DO
  270.       item := I.ItemAddress( menu , code ) ;
  271.       CASE GT.GTMENUITEM_USERDATA( item ) OF
  272.       | MENU_RUN  : count := -1 ;
  273.       | MENU_STEP : count :=  1 ;
  274.       | MENU_QUIT : count :=  0 ; terminated := TRUE ;
  275.  
  276.       | MENU_HSLOW: IF xstep > 0  THEN DEC( xstep ) END ;
  277.         GT.GT_SetGadgetAttrs( horizgad, controlwin, NIL, GT.GTSL_Level, xstep,
  278.                       U.TAG_DONE )
  279.  
  280.       | MENU_HFAST: IF xstep < 9 THEN INC( xstep ) END ;
  281.     GT.GT_SetGadgetAttrs( horizgad, controlwin, NIL, GT.GTSL_Level, xstep,
  282.                   U.TAG_DONE )
  283.  
  284.       | MENU_VSLOW: IF ystep > 0 THEN DEC( ystep ) END ;
  285.         GT.GT_SetGadgetAttrs( vertgad, controlwin, NIL, GT.GTSL_Level, ystep,
  286.                       U.TAG_DONE )
  287.  
  288.       | MENU_VFAST: IF ystep < 9 THEN INC( ystep ) END ;
  289.     GT.GT_SetGadgetAttrs( vertgad, controlwin, NIL, GT.GTSL_Level, ystep,
  290.                   U.TAG_DONE )
  291.       END ;
  292.       code := item^.NextSelect
  293.     END
  294.   END ;
  295.   RETURN terminated ;
  296. END handleIntuiMessage ;
  297.  
  298. (*----------------------------------------------------------------------------*)
  299.  
  300. PROCEDURE handleDBufMessage( dbmsg : E.MessagePtr ) ;
  301.   TYPE
  302.     AdrPtrPtr = POINTER TO POINTER TO S.ADDRESS ;
  303.  
  304.   VAR
  305.     buffer : LONGINT ;
  306.     adr       : S.ADDRESS ;
  307. BEGIN
  308.   (* dbi_SafeMessage is followed by an APTR dbi_UserData1, which  *)
  309.   (* contains the buffer number.  This is an easy way to extract  *)
  310.   (* it.                              *)
  311.   (* The dbi_SafeMessage tells us that it's OK to redraw the      *)
  312.   (* in the previous buffer.                      *)
  313.  
  314.   adr    := SIZE( E.Message ) + S.ADDRESS( dbmsg ) ;
  315.   buffer := LONGINT( adr( AdrPtrPtr)^ ) ;
  316.  
  317.   (* Mark the previous buffer as OK to redraw into.    *)
  318.   (* If you're using multiple ( >2 ) buffering, you    *)
  319.   (* would use                        *)
  320.   (*                            *)
  321.   (*    ( buffer + NUMBUFFERS - 1 ) % NUMBUFFERS    *)
  322.  
  323.   status[ORD(~VAL(BOOLEAN,buffer))] := OK_REDRAW
  324. END handleDBufMessage ;
  325.  
  326. (*----------------------------------------------------------------------------*)
  327.  
  328. (* Get the resources and objects we need *)
  329.  
  330. PROCEDURE init_all( ) : S.STRING ;
  331. BEGIN
  332.  
  333.   dbufport := E.CreateMsgPort( ) ;
  334.   IF dbufport = NIL THEN RETURN "Failed to create port\n" END ;
  335.  
  336.   userport := E.CreateMsgPort( ) ;
  337.   IF userport = NIL THEN RETURN "Failed to create port\n" END ;
  338.  
  339.   canvassc := I.OpenScreenTags( NIL,
  340.     I.SA_DisplayID, SC_ID,
  341.     I.SA_Overscan, I.OSCAN_TEXT,
  342.     I.SA_Depth, 2,
  343.     I.SA_AutoScroll, 1,
  344.     I.SA_Pens, pens,
  345.     I.SA_ShowTitle, TRUE,
  346.     I.SA_Title, "Intuition double-buffering example",
  347.     I.SA_VideoControl, vctags,
  348.     I.SA_SysFont, 1,
  349.     U.TAG_DONE ) ;
  350.   IF canvassc = NIL THEN RETURN "Couldn't open screen\n" END ;
  351.  
  352.   canvasvi := GT.GetVisualInfo( canvassc, U.TAG_DONE ) ;
  353.   IF canvasvi = NIL THEN RETURN "Couldn't get VisualInfo\n" END ;
  354.  
  355.   canvaswin := I.OpenWindowTags( NIL,
  356.     I.WA_NoCareRefresh, TRUE,
  357.     I.WA_Activate, TRUE,
  358.     I.WA_Borderless, TRUE,
  359.     I.WA_Backdrop, TRUE,
  360.     I.WA_CustomScreen, canvassc,
  361.     I.WA_NewLookMenus, TRUE,
  362.     U.TAG_DONE ) ;
  363.   IF canvaswin = NIL THEN RETURN "Couldn't open window\n" END ;
  364.  
  365.   canvaswin^.UserPort := userport ;
  366.  
  367.   I.ModifyIDCMP( canvaswin, I.IDCMP_MENUPICK+I.IDCMP_VANILLAKEY ) ;
  368.  
  369.   controlsc := I.OpenScreenTags( NIL,
  370.     I.SA_DisplayID, SC_ID,
  371.     I.SA_Overscan, I.OSCAN_TEXT,
  372.     I.SA_Depth, 2,
  373.     I.SA_Pens, pens,
  374.     I.SA_Top, CONTROLSC_TOP,
  375.     I.SA_Height, 28,
  376.     I.SA_Parent, canvassc,
  377.     I.SA_ShowTitle, FALSE,
  378.     I.SA_Draggable, FALSE,
  379.     I.SA_VideoControl, vctags,
  380.     I.SA_Quiet, TRUE,
  381.     I.SA_SysFont, 1,
  382.     U.TAG_DONE ) ;
  383.   IF controlsc = NIL THEN RETURN "Couldn't open screen\n" END ;
  384.  
  385.   controlvi := GT.GetVisualInfo( controlsc, U.TAG_DONE ) ;
  386.   IF controlvi = NIL THEN RETURN "Couldn't get VisualInfo\n" END ;
  387.  
  388.   menu := GT.CreateMenus( demomenu, U.TAG_DONE ) ;
  389.   IF menu = NIL THEN RETURN "Couldn't create menus\n" END ;
  390.  
  391.   IF ~GT.LayoutMenus( menu,canvasvi,GT.GTMN_NewLookMenus,TRUE,U.TAG_DONE ) THEN
  392.     RETURN "Couldn't layout menus\n" ;
  393.   END ;
  394.  
  395.   IF createAllGadgets( glist, controlvi ) = NIL THEN
  396.     RETURN "Couldn't create gadgets\n"
  397.   END ;
  398.  
  399.   (* A borderless backdrop window so we can get input *)
  400.   controlwin := I.OpenWindowTags( NIL,
  401.     I.WA_NoCareRefresh, TRUE,
  402.     I.WA_Activate, TRUE,
  403.     I.WA_Borderless, TRUE,
  404.     I.WA_Backdrop, TRUE,
  405.     I.WA_CustomScreen, controlsc,
  406.     I.WA_NewLookMenus, TRUE,
  407.     I.WA_Gadgets, glist,
  408.     U.TAG_DONE ) ;
  409.  
  410.   IF controlwin = NIL THEN RETURN "Couldn't open window\n" END ;
  411.  
  412.   controlwin^.UserPort := userport ;
  413.   I.ModifyIDCMP( controlwin,
  414.                GT.SLIDERIDCMP+I.IDCMP_MENUPICK+I.IDCMP_VANILLAKEY ) ;
  415.  
  416.   GT.GT_RefreshWindow( controlwin, NIL ) ;
  417.   I.SetMenuStrip( canvaswin, menu ) ;
  418.   I.LendMenus( controlwin, canvaswin ) ;
  419.  
  420.   scbuf[0] := I.AllocScreenBuffer( canvassc, NIL, I.SB_SCREEN_BITMAP ) ;
  421.   IF scbuf[0] = NIL THEN RETURN "Couldn't allocate ScreenBuffer 1\n" END ;
  422.  
  423.   scbuf[1] := I.AllocScreenBuffer( canvassc, NIL, I.SB_COPY_BITMAP ) ;
  424.   IF scbuf[1] = NIL THEN RETURN "Couldn't allocate ScreenBuffer 2\n" END ;
  425.  
  426.   (* Let's use the UserData to store the buffer number, for    *)
  427.   (* easy identification when the message comes back.        *)
  428.   scbuf[0]^.sb_DBufInfo^.dbi_UserData1 := 0 ;
  429.   scbuf[1]^.sb_DBufInfo^.dbi_UserData1 := 1 ;
  430.   status[0] := OK_REDRAW ;
  431.   status[1] := OK_REDRAW ;
  432.  
  433.   face := makeImageBM( ) ;
  434.   IF face = NIL THEN RETURN "Couldn't allocate image bitmap\n" END ;
  435.   G.InitRastPort( rport[0] ) ;
  436.   G.InitRastPort( rport[1] ) ;
  437.   rport[0].BitMap := scbuf[0]^.sb_BitMap ;
  438.   rport[1].BitMap := scbuf[1]^.sb_BitMap ;
  439.  
  440.   x    := 50 ;
  441.   y    := 70 ;
  442.   xstep :=  1 ;
  443.   xdir  :=  1 ;
  444.   ystep :=  1 ;
  445.   ydir  := -1 ;
  446.  
  447.   (* All is OK *)
  448.   RETURN NIL
  449. END init_all ;
  450.  
  451. (*----------------------------------------------------------------------------*)
  452.  
  453. (* Draw a crude "face" for animation *)
  454.  
  455. CONST
  456.   MAXVECTORS = 10 ;
  457.  
  458. PROCEDURE makeImageBM( ) : G.BitMapPtr ;
  459.   VAR
  460.     bm           : G.BitMapPtr ;
  461.     rport      : G.RastPort ;
  462.     area       : G.AreaInfo ;
  463.     tmpRas     : G.TmpRas ;
  464.     planePtr   : G.PLANEPTR ;
  465.     areabuffer : ARRAY [0..(MAXVECTORS*5-1)] OF SHORTINT ;
  466. BEGIN
  467.   bm := G.AllocBitMap( BM_WIDTH,BM_HEIGHT,BM_DEPTH,G.BMF_CLEAR,NIL ) ;
  468.   IF bm # NIL THEN
  469.      planePtr := G.AllocRaster( BM_WIDTH, BM_HEIGHT ) ;
  470.      IF planePtr # NIL THEN
  471.     G.InitRastPort( rport ) ;
  472.     rport.BitMap := bm ;
  473.  
  474.     G.InitArea( area, S.ADR( areabuffer ) , MAXVECTORS ) ;
  475.     rport.AreaInfo := S.ADR( area ) ;
  476.  
  477.     G.InitTmpRas( tmpRas, planePtr, G.RASSIZE( BM_WIDTH, BM_HEIGHT ) );
  478.     rport.TmpRas := S.ADR( tmpRas ) ;
  479.  
  480.     G.SetABPenDrMd( S.ADR( rport ) , 3 , 0 , G.JAM1 ) ;
  481.     G.AreaEllipse( S.ADR( rport ) , BM_WIDTH/2, BM_HEIGHT/2,
  482.         BM_WIDTH/2-4, BM_HEIGHT/2-4 );
  483.     G.AreaEnd( S.ADR( rport ) ) ;
  484.  
  485.     G.SetAPen( S.ADR( rport ) , 2 ) ;
  486.     G.AreaEllipse( S.ADR( rport ) , 5*BM_WIDTH/16 , BM_HEIGHT/4 ,
  487.         BM_WIDTH/9, BM_HEIGHT/9 );
  488.     G.AreaEllipse( S.ADR( rport ), 11*BM_WIDTH/16, BM_HEIGHT/4,
  489.         BM_WIDTH/9, BM_HEIGHT/9 ) ;
  490.     G.AreaEnd( S.ADR( rport ) ) ;
  491.  
  492.     G.SetAPen( S.ADR( rport ) , 1 );
  493.     G.AreaEllipse( S.ADR( rport ) , BM_WIDTH/2, 3*BM_HEIGHT/4,
  494.         BM_WIDTH/3, BM_HEIGHT/9 );
  495.     G.AreaEnd( S.ADR( rport ) ) ;
  496.  
  497.     G.FreeRaster( planePtr, BM_WIDTH, BM_HEIGHT ) ;
  498.       ELSE
  499.     G.FreeBitMap( bm ) ;
  500.     bm := NIL ;
  501.       END ;
  502.     RETURN bm ;
  503.   END ;
  504. END makeImageBM ;
  505.  
  506. (*----------------------------------------------------------------------------*)
  507.  
  508. (* Make a pair of slider gadgets to control horiz and vertical speed of motion*)
  509.  
  510. PROCEDURE createAllGadgets( VAR glistptr : I.GadgetPtr ;
  511.                           vi : S.ADDRESS ) : I.GadgetPtr ;
  512.   VAR
  513.     ng  : GT.NewGadget ;
  514.     gad : I.GadgetPtr  ;
  515. BEGIN
  516.   gad := GT.CreateContext( glistptr ) ;
  517.  
  518.   ng.ng_LeftEdge   := 100 ;
  519.   ng.ng_TopEdge       := 1 ;
  520.   ng.ng_Width       := 100 ;
  521.   ng.ng_Height       := 12 ;
  522.   ng.ng_GadgetText := "Horiz:  " ;
  523.   ng.ng_TextAttr   := S.ADR( Topaz80 ) ;
  524.   ng.ng_VisualInfo := vi ;
  525.   ng.ng_GadgetID   := GAD_HORIZ ;
  526.   ng.ng_Flags       := { } ;
  527.  
  528.   gad := GT.CreateGadget( GT.SLIDER_KIND, gad, ng ,
  529.     GT.GTSL_Min, 0,
  530.     GT.GTSL_Max, 9,
  531.     GT.GTSL_Level, 1,
  532.     GT.GTSL_MaxLevelLen, 1,
  533.     GT.GTSL_LevelFormat, "%ld",
  534.     U.TAG_DONE ) ;
  535.  
  536.   horizgad := gad ;
  537.  
  538.   INC( ng.ng_LeftEdge, 200 ) ;
  539.   ng.ng_GadgetID := GAD_VERT;
  540.   ng.ng_GadgetText := "Vert:  ";
  541.   vertgad := GT.CreateGadget( GT.SLIDER_KIND, gad, ng ,
  542.     GT.GTSL_Min, 0,
  543.     GT.GTSL_Max, 9,
  544.     GT.GTSL_Level, 1,
  545.     GT.GTSL_MaxLevelLen, 1,
  546.     GT.GTSL_LevelFormat, "%ld",
  547.     U.TAG_DONE );
  548.  
  549.   gad := vertgad ;
  550.   RETURN gad  ;
  551. END createAllGadgets ;
  552.  
  553. (*----------------------------------------------------------------------------*)
  554.  
  555. (* Clean up everything and exit, printing the errorstring if any *)
  556. PROCEDURE error_exit( errorstring : S.STRING ) ;
  557. BEGIN
  558.   IF controlwin # NIL THEN
  559.     I.ClearMenuStrip( controlwin ) ;
  560.     CloseWindowSafely( controlwin ) ;
  561.   END ;
  562.  
  563.   IF canvaswin # NIL THEN
  564.     I.ClearMenuStrip( canvaswin ) ;
  565.     CloseWindowSafely( canvaswin ) ;
  566.   END ;
  567.  
  568.   IF controlsc # NIL THEN I.CloseScreen( controlsc ) END ;
  569.  
  570.   IF canvassc # NIL THEN
  571.     I.FreeScreenBuffer( canvassc, scbuf[1] ) ;
  572.     I.FreeScreenBuffer( canvassc, scbuf[0] ) ;
  573.     I.CloseScreen( canvassc ) ;
  574.   END ;
  575.  
  576.   IF dbufport # NIL THEN E.DeleteMsgPort( dbufport ) END ;
  577.   IF userport # NIL THEN E.DeleteMsgPort( userport ) END ;
  578.  
  579.   GT.FreeGadgets( glist ) ;
  580.   GT.FreeMenus( menu ) ;
  581.   GT.FreeVisualInfo( canvasvi ) ;
  582.   GT.FreeVisualInfo( controlvi ) ;
  583.  
  584.   IF face # NIL THEN G.FreeBitMap( face ) END ;
  585.  
  586.   IF errorstring # NIL THEN D.Printf( "%s",errorstring ) ; SLib.exit(20) END ;
  587.  
  588.   SLib.exit( 0 ) ;
  589. END error_exit ;
  590.  
  591. (*----------------------------------------------------------------------------*)
  592.  
  593. (* these functions close an Intuition window    *)
  594. (* that shares a port with other Intuition    *)
  595. (* windows or IPC customers.            *)
  596. (*                        *)
  597. (* We are careful to set the UserPort to    *)
  598. (* null before closing, and to free        *)
  599. (* any messages that it might have been        *)
  600. (* sent.                    *)
  601.  
  602. PROCEDURE CloseWindowSafely( win : I.WindowPtr ) ;
  603. BEGIN
  604.   E.Forbid(); (* we forbid here to keep out of race conditions with Intuition *)
  605.  
  606.   (* send back any messages for this window that have not yet been processed *)
  607.   StripIntuiMessages( win^.UserPort, win );
  608.  
  609.   (* clear UserPort so Intuition will not free it *)
  610.   win^.UserPort := NIL ;
  611.  
  612.   (* tell Intuition to stop sending more messages *)
  613.   I.ModifyIDCMP( win , { } ) ;
  614.  
  615.   (* turn multitasking back on *)
  616.   E.Permit() ;
  617.  
  618.   (* and really close the window *)
  619.   I.CloseWindow( win ) ;
  620.  
  621. END CloseWindowSafely ;
  622.  
  623. (* remove and reply all IntuiMessages on a port that    *)
  624. (* have been sent to a particular window        *)
  625. (* ( note that we don't rely on the ln_Succ pointer    *)
  626. (*  of a message after we have replied it )        *)
  627.  
  628. PROCEDURE StripIntuiMessages( mp : E.MsgPortPtr ; win : I.WindowPtr ) ;
  629.   VAR
  630.     msg  : I.IntuiMessagePtr ;
  631.     succ : E.NodePtr ;
  632. BEGIN
  633.   msg := I.IntuiMessagePtr( mp^.mp_MsgList.lh_Head ) ;
  634.   LOOP
  635.     succ :=  msg^.ExecMessage.mn_Node.ln_Succ ;
  636.     IF succ = NIL THEN EXIT END ;
  637.     IF msg^.IDCMPWindow = win THEN
  638.       (* Intuition is about to free this message.    *)
  639.       (* Make sure that we have politely sent it back.    *)
  640.       E.Remove( E.NodePtr( msg ) ) ;
  641.       E.ReplyMsg( msg ) ;
  642.     END ;
  643.     msg := I.IntuiMessagePtr( succ ) ;
  644.   END ;
  645. END StripIntuiMessages ;
  646.  
  647. (*----------------------------------------------------------------------------*)
  648.  
  649. BEGIN
  650.   scbuf    := [NIL,NIL] ;
  651.   prevx    := [ 50, 50] ;
  652.   prevy    := [ 50, 50] ;
  653.   Topaz80  := ["topaz.font",8,{},{}];
  654.   vctags   := [[G.VTAG_BORDERSPRITE_SET,TRUE],[U.TAG_DONE,0]] ;
  655.   pens       := [0,1,1,2,1,3,1,0,2,1,2,1,MAX(CARDINAL)] ;
  656.   demomenu :=
  657.        [
  658.         [ GT.NM_TITLE,"Project" ],
  659.     [ GT.NM_ITEM, "Run",            "R", {}, 0, MENU_RUN   ],
  660.     [ GT.NM_ITEM, "Step",            "S", {}, 0, MENU_STEP  ],
  661.     [ GT.NM_ITEM, GT.NM_BARLABEL ],
  662.     [ GT.NM_ITEM, "Slower Horizontal", "1", {}, 0, MENU_HSLOW ],
  663.     [ GT.NM_ITEM, "Faster Horizontal", "2", {}, 0, MENU_HFAST ],
  664.     [ GT.NM_ITEM, "Slower Vertical",   "3", {}, 0, MENU_VSLOW ],
  665.     [ GT.NM_ITEM, "Faster Vertical",   "4", {}, 0, MENU_VFAST ],
  666.     [ GT.NM_ITEM, GT.NM_BARLABEL],
  667.     [ GT.NM_ITEM, "Quit",            "Q", {}, 0, MENU_QUIT  ],
  668.     [ GT.NM_END ]
  669.        ] ;
  670.   main( )
  671. END DoubleBuffer.
  672.