PROGRAM FBasicHAMDemo

? This program is a modification of an example program which appeared
? in V3.10 of Amazing Computing (p.89). It demonstrates the Hold And Modify
? mode (HAM) of the Amiga, by painting the screen full of HAM colors. If an
? error occurs, the speech facilities of the Amiga announce the problem.
? For another variation, remove the '?' comment symbol from the line
? pen=0 in the loop.

? The published times for this program's screen filling operation were:
?                Amiga Basic       ---  6 minutes, 30 seconds
?          AC/BASIC compiler V1.3  ---  1 minute,  50 seconds
?             F-Basic's time is    ---  39 seconds

INCLUDE finclude/AmigaExecTypes
INCLUDE finclude/AmigaGraphicsTypes

INTEGER x,y,pen,startx,starty,GfxsBase,IntBase,ScreenPtr,ViewPtr
NewScreen NScreen
NewWindow NWind
PTR_TO RastPort RastPtr
PTR_TO Window WindPtr
DATA (GfxsBase,0),(IntBase,0),(ScreenPtr,0),(pen,0)
DATA (WindPtr,0),(RastPtr,0),(ViewPtr,0)
SUBPROGRAM
   SUBROUTINE WARN
&SYSLIB 1

GfxsBase=OPENLIB("graphics.library",0)
IntBase=OPENLIB("intuition.library",0)
IF (NOT GfxsBase) OR (NOT IntBase) THEN
   WARN("Unable To Open Libraries")
   GOTO CloseAll
ENDIF

? Create the data structures necessary to create our own Screen/Window

NScreen.Width=320 ; NScreen.Height=200 ; NScreen.Depth=6
NScreen.ViewModes=800'16 ; ? Hold And Modify Mode
NScreen.Type=F'16 ; ? Custom Screen
NWind.Width=320 ; NWind.Height=200 ; NWind.BlockPen=1
NWind.MinWidth=320 ; NWind.MinHeight=200
NWind.MaxWidth=320 ; NWind.MaxHeight=200
NWind.Type=F'16 ; ? Custom Screen
NWind.Flags=1800'16 ; ? Borderless|Activate

ScreenPtr=OpenScreen(IntBase,@NScreen)
IF NOT ScreenPtr THEN
   WARN("Unable To Open Screen")
   GOTO CloseAll
ENDIF
NWind.Screen=ScreenPtr
WindPtr=OpenWindow(IntBase,@NWind)
IF NOT WindPtr THEN
   WARN("Unable To Open The Window")
   GOTO CloseAll
ENDIF
ViewPtr=ViewPortAddress(IntBase,WindPtr)
RastPtr=#(WindPtr+50)
IF NOT RastPtr THEN
   WARN("Unable To Locate RastPort")
   GOTO CloseAll
ENDIF

? Display text heading above the drawing area

Move(GfxsBase,RastPtr,1,8)
Text(GfxsBase,RastPtr,@"An F-Basic HAM Screen...",24)

WARN("Let The Show Begin")
starty=10
FOR startx=1 TO 199
   y=starty
   pen=0                               ; ? start with color reg 0
   FOR x=startx TO 320
      pen=(pen+1) AND 63               ; ? cycle through 0-63
      SetAPen(GfxsBase,RastPtr,pen)
      WritePixel(GfxsBase,RastPtr,x,y)
   NEXT x
?   pen=0                              ; ? reset color reg to 0
   FOR y=starty TO 200
      x=startx+1
      pen=(pen+1) AND 63               ; ? cycle through 0-63
      SetAPen(GfxsBase,RastPtr,pen)
      WritePixel(GfxsBase,RastPtr,x,y)
   NEXT y
   starty=starty+1
NEXT startx

? Wait 10 seconds before cleanup
DELAY(100)

{CloseAll}
   IF WindPtr THEN CloseWindow(IntBase,WindPtr)
   IF ScreenPtr THEN CloseScreen(IntBase,ScreenPtr)
   IF IntBase THEN x=CLOSELIB(IntBase)
   IF GfxsBase THEN x=CLOSELIB(GfxsBase)
END
SUBROUTINE WARN
PARAMETER
   TEXT*$ PARAM
LOCAL
   INTEGER I
   TEXT*120 STR
I=FILLCHAR(STR," ")
I=TRANSLATE(PARAM,STR)
I=NARRATE(STR)
GRETURN
END