home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Club Amiga de Montreal - CAM
/
CAM_CD_1.iso
/
files
/
015.lha
/
FScapePlus
(
.txt
)
< prev
next >
Wrap
AmigaBASIC Source Code
|
1986-11-10
|
25KB
|
873 lines
'*** FScapePlus *** 30-Nov-86 *** Mike Steed *** Public Domain ***
IF FRE(-1)<80000 OR FRE(-3)<50000 THEN PRINT "Sorry, not enough memory." : END
CLEAR ,50000 'make room
GOSUB Init
Main:
Mode = 1 : Idle = 1 : GOSUB MenuUpdate
MenuVec = 0
MainLp: 'can't SLEEP (?)
IF INKEY$ = CHR$(139) THEN Help
ON MenuVec GOTO MenuProject,Main,MenuWindow,MenuColor
GOTO MainLp
'*** Menu Control ***
MenuProject:
ON MenuSubVec GOTO DoFscape,ReDraw,CycleScape,Main,Quit
GOTO Main
MenuFile: 'come here from CtrlPanel
ON MenuSubVec GOTO LoadFScape,SaveFScape
MenuWindow:
ON MenuSubVec GOSUB DsplyWindow,CtrlWindow
GOTO Main
MenuColor:
ColorMode = MenuSubVec : GOSUB SetColors
GOTO Main
Help:
CALL YesNoReq("For help with FScapePlus,|see the file FScapePlus.doc","","OK",200,64,Dummy)
GOTO Main
'*** Hi Level Stuff ***
DsplyWindow:
WINDOW 2
RETURN
CtrlWindow:
Mode = 0 : GOSUB MenuUpdate
WINDOW 1
GOSUB SetControls
GOSUB CtrlLoop
GOSUB GetControls
WINDOW 2 : RETURN
DoFscape:
IF AutoSeed THEN GOSUB GenSeed
GOSUB Fscape
GOTO Main
ReDraw: 'Redraw existing array
Idle = 0 : GOSUB MenuUpdate
GOSUB FDraw
GOTO Main
CycleScape: 'Continuous FScapes
OldSeed% = Seed%
CycleScape2:
GOSUB GenSeed
GOSUB Fscape
GOTO CycleScape2 'Menu Stop gets us out
Fscape: 'Create & draw an FScape
Idle = 0 : GOSUB MenuUpdate
GOSUB FInit
GOSUB FCreate
GOSUB FDraw
RETURN
Quit: 'That's all, folks!
CALL YesNoReq("Exit to:","System","Basic",200,64,Systm%)
MENU RESET
WINDOW 1 : CLS
WINDOW CLOSE 2 : SCREEN CLOSE 2
IF Systm% THEN SYSTEM :ELSE END
FDraw: 'Draw FScape
OldSeed% = Seed%
IF ClrScn THEN COLOR 1,0 : CLS
GOSUB PlotZ
GOSUB PlotY
GOSUB PlotX
RETURN
'*** File Routines ***
LoadFScape:
CALL StringReq("Load FScape File:",FileName$,"Load","",200,64,DoIt)
IF NOT DoIt THEN RETURN
OPEN FileName$+".fscape" FOR INPUT AS 1
INPUT #1, Seed%,le,rg,cx,cy,xs,ys,zs,AutoSeed,ClrScn,SeaLev%
CLOSE #1
GOSUB SetControls
d(1,0) = 0 'no redraw
RETURN
SaveFScape:
CALL StringReq("Save FScape File:",FileName$,"Save","",200,64,DoIt)
IF NOT DoIt THEN RETURN
GOSUB GetControls 'update variables
OPEN FileName$+".fscape" FOR OUTPUT AS 1
WRITE #1, Seed%,le,rg,cx,cy,xs,ys,zs,0,ClrScn,SeaLev% 'auto seed always off
CLOSE #1
RETURN
ErrorHandler: 'come here on error
IF ERR = 53 THEN ErrMsg$ = "Can't find that file." : GOTO GiveError
IF ERR = 64 THEN ErrMsg$ = "Can't use that filename." : GOTO GiveError
IF ERR = 70 THEN ErrMsg$ = "Disk is write-protected." : GOTO GiveError
IF ERR = 49 THEN ErrMsg$ = "Can't find that volume." : GOTO GiveError
IF ERR = 61 THEN ErrMsg$ = "The disk is full." : GOTO GiveError
ON ERROR GOTO 0 'let Basic handle others
GiveError:
CALL YesNoReq (ErrMsg$,"","Oops",200,64,Dummy%)
CLOSE
RESUME MenuFile
'*** Fractal Landscape Subroutines ***
FInit: 'Init for create or draw
Dummy = RND(Seed%)
ds = 2^le+1
mx = ds-1 : my = mx/2 : rh = Pi/6 : vt = -Pi/5
rc = COS(rh) : rs = SIN(rh)
vc = COS(vt) : vs = SIN(vt)
RETURN
FCreate: 'Create a fractal array
FOR n = 1 TO le
l = rg/1.8^n : L2 = l/2 : L4 = l/4
ib = mx/2^n : sk = ib*2
GOSUB XHeight
GOSUB YHeight
GOSUB ZHeight
NEXT
RETURN
DefSettings: 'Defaults for adjustable parms
xs = 0.04 : ys = 0.04 : zs = 0.05 : cx = 0 : cy = 48 : rg = 12000
SeaLev% = 0 : le = 5 : ClrScn = -1 : AutoSeed = -1
RETURN
XHeight: 'Calculate heights along X axis
FOR ye = 0 TO mx-1 STEP sk
FOR xe = ib+ye TO mx STEP sk
ax = xe-ib : ay = ye : GOSUB GetDat : d1 = d : ax = xe+ib : GOSUB GetDat : d2 = d
d = (d1+d2)/2+RND*L2-L4 : ax = xe : ay = ye : GOSUB PutDat
NEXT xe
NEXT ye
RETURN
YHeight: 'Calculate heights along Y axis
FOR xe = mx TO 1 STEP -sk
FOR ye = ib TO xe STEP sk
ax = xe : ay = ye+ib : GOSUB GetDat : d1 = d : ay = ye-ib : GOSUB GetDat : d2 = d
d = (d1+d2)/2+RND*L2-L4 : ax = xe : ay = ye : GOSUB PutDat
NEXT ye
NEXT xe
RETURN
ZHeight: 'Calculate heights along Z axis
FOR xe = 0 TO mx-1 STEP sk
FOR ye = ib TO mx-xe STEP sk
ax = xe+ye-ib : ay = ye-ib : GOSUB GetDat : d1 = d
ax = xe+ye+ib : ay = ye+ib : GOSUB GetDat : d2 = d
ax = xe+ye : ay = ye : d = (d1+d2)/2+RND*L2-L4 : GOSUB PutDat
NEXT ye
NEXT xe
RETURN
GetDat: 'Get a data point from array
IF ay > my THEN
by = mx+1-ay : bx = mx-ax
ELSE
by = ay : bx = ax
END IF
d = d(bx,by)
RETURN
PutDat: 'Put a data point into array
IF ay > my THEN
by = mx+1-ay : bx = mx-ax
ELSE
by = ay : bx = ax
END IF
d(bx,by) = d
RETURN
SeaLevel: 'this code is a bit ugly...
IF NOT SeaLev% THEN GOTO Colors 'not doing sea level
IF xo <> -999 THEN SeaLevel2
IF zz < 0 THEN
Colr = 5 : z2 = zz : zz = 0
ELSE
Colr = 2 : z2 = zz
END IF
GOTO ExitSeaLevel
SeaLevel2:
IF z2 > 0 AND zz > 0 THEN GOSUB Colors : z2 = zz : GOTO ExitSeaLevel
IF z2 < 0 AND zz < 0 THEN z2 = zz : zz = 0 : GOTO ExitSeaLevel
IF zz = z2 THEN w3 = 0.5 :ELSE w3 = zz/(zz-z2)
x3 = (x2-xx)*w3+xx : y3 = (y2-yy)*w3+yy : z3 = 0
zt = zz : yt = yy : xt = xx
IF zz > 0 THEN 'coming out of water
zz = z3 : yy = y3 : xx = x3 : GOSUB Plot2
Colr = 2 : zz = zt : yy = yt : xx = xt : z2 = zz
ELSE 'going into water
zz = z3 : yy = y3 : xx = x3 : GOSUB Plot2
Colr = 5 : zz = 0 : yy = yt :xx = xt : z2 = zt
END IF
ExitSeaLevel:
x2 = xx : y2 = yy : RETURN
Colors: 'convert altitude to color
IF zz < 0 THEN BelowWater
IF zz < 250 THEN Colr = 2 : RETURN 'dk green
IF zz < 550 THEN Colr = 3 : RETURN 'med green
IF zz < 950 THEN Colr = 4 : RETURN 'lt brown
Colr = 1 : RETURN 'white
BelowWater:
IF zz > -600 THEN Colr = 5 : RETURN 'blue
Colr = 6 : RETURN 'med blue
Plot: 'Draw a line between two points
GOSUB SeaLevel
Plot2: 'skip sea level
xx = xx*xs : yy = yy*ys : zz = zz*zs
ox = xx 'Rotation
xx = xx*rc-yy*rs
yy = ox*rs+yy*rc
ox = xx 'Tilt down
xx = vc*xx-vs*zz
zz = vs*ox+vc*zz
xp = INT(yy) : yp = INT(zz)
xp = xp*1.38+cx : yp = cy-0.663*yp
IF xo = -999 THEN PSET (xp,yp),Colr :ELSE LINE -(xp,yp),Colr
x8 = xp : y8 = yp : xo = xp
RETURN
PlotX: 'Plot X axis
FOR ax = 0 TO mx : xo = -999
FOR ay = 0 TO ax
GOSUB GetDat : zz = d : yy = ay/mx*EE4 : xx = ax/mx*EE4-yy/2
GOSUB Plot
NEXT ay
NEXT ax
RETURN
PlotY: 'Plot Y axis
FOR ay = 0 TO mx : xo = -999
FOR ax = ay TO mx
GOSUB GetDat : zz = d : yy = ay/mx*EE4 : xx = ax/mx*EE4-yy/2
GOSUB Plot
NEXT ax
NEXT ay
RETURN
PlotZ: 'Plot Z azis
FOR ex = 0 TO mx : xo = -999
FOR ey = 0 TO mx-ex
ax = ex+ey : ay = ey : GOSUB GetDat : zz = d : yy = ay/mx*EE4
xx = ax/mx*EE4-yy/2
GOSUB Plot
NEXT ey
NEXT ex
RETURN
'*** Menu Subroutines ***
MenuSel: 'come here on menu select
MSVOld = MenuSubVec 'where were we?
MenuVec = MENU(0) : MenuSubVec = MENU(1)
IF MenuVec = 1 AND MenuSubVec = 4 THEN 'Stop
IF MSVOld = 1 THEN d(1,0) = 0 'disable redraw
IF MSVOld = 3 THEN Seed% = OldSeed%
RETURN Main
END IF
RETURN
MenuSetup: 'Create menus
MENU 1,0,0,"Project"
MENU 1,1,1,"New "
MENU 1,2,1,"Redraw"
MENU 1,3,1,"Cycle "
MENU 1,4,1,"Stop "
MENU 1,5,1,"Quit "
MENU 2,0,0,"File"
MENU 2,1,1,"Load"
MENU 2,2,1,"Save"
MENU 3,0,0,"Window"
MENU 3,1,1,"Display"
MENU 3,2,1,"Control"
MENU 4,0,0,"Color"
MENU 4,1,2," Normal "
MENU 4,2,1," Color Print"
MENU 4,3,1," B&W Print "
RETURN
MenuUpdate: 'Update menus
MnuMode = Idle AND Mode 'Mode: 1 = Display, 0 = CtrlPanel; Idle: 1 = stopped, 0 = running
MnuReDraw = Idle AND (d(1,0) <> 0) 'can't redraw if no array
MnuColr1 = 1-(ColorMode = 1)
MnuColr2 = 1-(ColorMode = 2)
MnuColr3 = 1-(ColorMode = 3)
PALETTE 7,1-MnuMode,MnuMode,0 'Green for go, red for stop
MENU 1,0,Mode
MENU 1,1,Idle
MENU 1,2,MnuReDraw
MENU 1,3,Idle
MENU 1,4,1-Idle
MENU 1,5,Idle
MENU 2,0,1-Mode
MENU 3,0,Idle
MENU 3,1,1-Mode
MENU 3,2,Mode
MENU 4,0,MnuMode
MENU 4,1,MnuColr1
MENU 4,2,MnuColr2
MENU 4,3,MnuColr3
RETURN
'*** Initialize ***
Init:
DEFINT a-n
WINDOW 1,"Control Panel",(0,1)-(617,186),23,-1
SCREEN 2,640,200,3,2
WINDOW 2,"FScapePlus",(0,1)-(631,186),0,2
Mode = 1 : GOSUB MenuSetup 'Idle = 0
ColorMode = 1 : GOSUB SetColors
ON MENU GOSUB MenuSel : MENU ON
COLOR 2,0 : LOCATE 8,27 : PRINT "===== FScapePlus ====="
LOCATE 10,27 : PRINT "=== By Mike Steed ==="
LOCATE 12,27 : PRINT "==== v1.0 Nov. '86 ===="
COLOR 5,0 : LOCATE 18,26 : PRINT "Be with you in a moment..."
ON ERROR GOTO ErrorHandler
ON BREAK GOSUB Quit : BREAK ON 'exit gracefully
RANDOMIZE TIMER : GOSUB GenSeed
DIM d(128,64)
Pi = 3.14159 : Pi2 = Pi/2 : EE4 = 10000
GOSUB DefSettings
WINDOW OUTPUT 1 : GOSUB CtrlInit : GOSUB DrawCtrlPanel 'Init control panel
WINDOW OUTPUT 2 : CLS
RETURN
'*** Subroutines ***
SetColors:
ON ColorMode GOTO NormColor,ColorPrint,BWPrint
NormColor:
PALETTE 0,0,0,0 : PALETTE 1,1,1,1
PALETTE 4,9/15,9/15,3/15 : PALETTE 2,2/15,7/15,0/15
PALETTE 3,0,10/15,2/15 : PALETTE 5,0,0,12/15
PALETTE 6,0,0,7/15
RETURN
ColorPrint:
GOSUB NormColor
PALETTE 0,1,1,1 : PALETTE 1,11/15,11/15,11/15
RETURN
BWPrint:
PALETTE 0,1,1,1
FOR i = 1 TO 6
PALETTE i,0,0,0
NEXT
RETURN
GenSeed: 'generate a random seed number
Seed% = -32767*RND-1
FileName$ = "" 'new seed = new 'scape
RETURN
'*** Control Panel ***
CtrlInit: 'init control arrays
DIM SHARED Ctrl.PotX(5) : DIM SHARED Ctrl.PotY(5) 'X,Y of title
DIM SHARED Ctrl.PotUL(5,1) : DIM SHARED Ctrl.PotLR(5,1) 'X,Y of slider
DIM SHARED Ctrl.PotTitle$(5) 'title
DIM SHARED Ctrl.PotValue(5) '0-286
DIM SHARED Ctrl.SwX(2) : DIM SHARED Ctrl.SwY(2) 'X,Y of title
DIM SHARED Ctrl.SwUL(2,1) : DIM SHARED Ctrl.SwLR(2,1) 'X,Y of switch
DIM SHARED Ctrl.SwTitle$(2) 'title
DIM SHARED Ctrl.SwLab$(2) 'On-Off labels
DIM SHARED Ctrl.SwOnOff(2) '-1=on, 0=off
DIM SHARED Ctrl.BtnX(1) : DIM SHARED Ctrl.BtnY(1) 'X,Y of 1st title line
DIM SHARED Ctrl.BtnUL(1,1) : DIM SHARED Ctrl.BtnLR(1,1) 'X,Y of button
DIM SHARED Ctrl.BtnTitle$(1,1) 'title lines
DIM SHARED Ctrl.BtnOnOff(1) '-1=on, 0=off
DIM SHARED Ctrl.SelX(0) : DIM SHARED Ctrl.SelY(0) 'X,Y of title
DIM SHARED Ctrl.SelUL(0,1) : DIM SHARED Ctrl.SelLR(0,1) 'X,Y of sel. box
DIM SHARED Ctrl.SelTitle$(0) 'title
DIM SHARED Ctrl.SelPosns(0) 'no. of sel. positions
DIM SHARED Ctrl.SelSetting(0) 'current setting
DIM SHARED Ctrl.TBoxX(0) : DIM SHARED Ctrl.TBoxY(0) 'X,Y of title
DIM SHARED Ctrl.TBoxUL(0,1) : DIM SHARED Ctrl.TBoxLR(0,1) 'X,Y of text box
DIM SHARED Ctrl.TBoxTitle$(0) 'title
DIM SHARED Ctrl.TBoxWidth(0) '# of chars allowed
DIM SHARED Ctrl.TBoxText$(0) 'contents of box
RETURN
DrawCtrlPanel: 'draw outlines
RESTORE CtrlData
FOR i = 0 TO 5
READ Ctrl.PotX(i) : READ Ctrl.PotY(i) : READ Ctrl.PotTitle$(i)
CALL DrawPot(i)
NEXT
FOR i = 0 TO 2
READ Ctrl.SwX(i) : READ Ctrl.SwY(i) : READ Ctrl.SwTitle$(i) : READ Ctrl.SwLab$(i)
CALL DrawSwitch(i)
NEXT
FOR i = 0 TO 1
READ Ctrl.BtnX(i) : READ Ctrl.BtnY(i) : READ Ctrl.BtnTitle$(i,0) : READ Ctrl.BtnTitle$(i,1)
CALL DrawButton(i)
NEXT
FOR i = 0 TO 0
READ Ctrl.SelX(0) : READ Ctrl.SelY(0) : READ Ctrl.SelTitle$(0) : READ Ctrl.SelPosns(0)
CALL DrawSelector(0)
NEXT
FOR i = 0 TO 0
READ Ctrl.TBoxX(i) : READ Ctrl.TBoxY(i) : READ Ctrl.TBoxTitle$(i) : READ Ctrl.TBoxWidth(i)
CALL DrawTextBox(i)
NEXT
LOCATE 23,32 : COLOR 3,0 : PRINT "F S c a p e P l u s";
GOSUB SetControls 'draw controls
RETURN
CtrlData:
DATA 5,2,"Flatlands Terrain Rugged"
DATA 5,6,"Left Horizontal Position Right"
DATA 5,9,"Down Vertical Position Up"
DATA 5,13,"Small X Scale Factor Large"
DATA 5,16,"Small Y Scale Factor Large"
DATA 5,19,"Small Z Scale Factor Large"
DATA 47,9," Auto Seeding","Yes No"
DATA 62,13,"Auto Scrn Clr","Yes No"
DATA 47,13," Sea Level","On Off"
DATA 53,19,"Restore","Defaults"
DATA 62,9," Manual"," Reseed"
DATA 47,2,"1 (Fast) Level (Slow) 7",7
DATA 47,6,"Seed Number (1-32768)",5
SetControls: 'transfer variables to controls
Ctrl.PotValue(0) = (rg-1000)/67 : CALL AdjPot(0)
Ctrl.PotValue(1) = (cx+300)/3 : CALL AdjPot(1)
Ctrl.PotValue(2) = 286-cy*2 : CALL AdjPot(2)
Ctrl.PotValue(3) = (xs-0.01)*3178 : CALL AdjPot(3)
Ctrl.PotValue(4) = (ys-0.01)*3178 : CALL AdjPot(4)
Ctrl.PotValue(5) = (zs-0.01)*3178 : CALL AdjPot(5)
Ctrl.SwOnOff(0) = AutoSeed : CALL AdjSwitch(0)
Ctrl.SwOnOff(1) = ClrScn : CALL AdjSwitch(1)
Ctrl.SwOnOff(2) = SeaLev% : CALL AdjSwitch(2)
Ctrl.BtnOnOff(0) = 0 : CALL AdjButton(0)
Ctrl.BtnOnOff(1) = 0 : CALL AdjButton(1)
Ctrl.SelSetting(0) = le : CALL AdjSelector(0)
SetSeed: 'just set seed box
Ctrl.TBoxText$(0) = MID$(STR$(ABS(Seed%)),2) : CALL SetTextBox(0) 'no leading blank
RETURN
GetControls: 'read controls into variables
rg = 1000+67*Ctrl.PotValue(0)
cx = Ctrl.PotValue(1)*3-300
cy = 143-Ctrl.PotValue(2)/2
xs = Ctrl.PotValue(3)/3178+0.01
ys = Ctrl.PotValue(4)/3178+0.01
zs = Ctrl.PotValue(5)/3178+0.01
AutoSeed = Ctrl.SwOnOff(0)
ClrScn = Ctrl.SwOnOff(1)
SeaLev% = Ctrl.SwOnOff(2)
le = Ctrl.SelSetting(0)
GetSeed: 'get just seed
Seed% = -VAL(Ctrl.TBoxText$(0))
RETURN
CtrlLoop: 'run Control Panel
WHILE MOUSE(0) = 0 'wait for click
IF MenuVec = 2 THEN GOSUB MenuFile : MenuVec = 0
IF MenuVec = 3 AND MenuSubVec = 1 THEN RETURN 'back to display
FOR i = 0 TO 1 : Ctrl.BtnOnOff(i) = 0 : CALL AdjButton(i) : NEXT 'all buttons off
WEND
mousex = MOUSE (1) : mousey = MOUSE(2)
IF mousex<350 THEN 'left half of screen
FOR i = 0 TO 5 'do pots
IF mousey>=Ctrl.PotUL(i,1) AND mousey<=Ctrl.PotLR(i,1) THEN
IF mousex>=Ctrl.PotUL(i,0)+5 AND mousex<=Ctrl.PotLR(i,0)-5 THEN
Ctrl.PotValue(i) = mousex-5-Ctrl.PotUL(i,0) : CALL AdjPot(i)
IF i = 0 THEN d(1,0) = 0
END IF
END IF
NEXT
ELSE 'right half of screen
FOR i = 0 TO 0 'do selectors
IF mousey>=Ctrl.SelUL(i,1) AND mousey<=Ctrl.SelLR(i,1) THEN
IF mousex>=Ctrl.SelUL(i,0) AND mousex<=Ctrl.SelLR(i,0) THEN
SelWidth% = (226-3*(Ctrl.SelPosns(i)+1))/Ctrl.SelPosns(0)
FOR j = 0 TO Ctrl.SelPosns(i)-1
LftEdge = Ctrl.SelUL(i,0)+1+j*(SelWidth%+3)
IF (mousex>=LftEdge%) AND (mousex<=LftEdge+SelWidth%+1) THEN Ctrl.SelSetting(SelNum%) = j+1 : CALL AdjSelector(i)
d(1,0) = 0 'no redraw
NEXT
END IF
END IF
NEXT
FOR i = 0 TO 2 'do switches
IF mousey>=Ctrl.SwUL(i,1) AND mousey<=Ctrl.SwLR(i,1) THEN
IF mousex>=Ctrl.SwUL(i,0) AND mousex<=Ctrl.SwLR(i,0) THEN
IF mousex<Ctrl.SwUL(i,0)+23 THEN Ctrl.SwOnOff(i) = -1 :ELSE Ctrl.SwOnOff(i) = 0
CALL AdjSwitch(i)
END IF
END IF
NEXT
FOR i = 0 TO 1 'do buttons
IF mousey>=Ctrl.BtnUL(i,1) AND mousey<=Ctrl.BtnLR(i,1) THEN
IF mousex>=Ctrl.BtnUL(i,0) AND mousex<=Ctrl.BtnLR(i,0) THEN
Ctrl.BtnOnOff(i) = -1 : CALL AdjButton(i)
ELSE
Ctrl.BtnOnOff(i) = 0
END IF
ELSE
Ctrl.BtnOnOff(i) = 0
END IF
NEXT
FOR i = 0 TO 0 'do text boxes
IF mousey>=Ctrl.TBoxUL(i,1) AND mousey<=Ctrl.TBoxLR(i,1) THEN
IF mousex>=Ctrl.TBoxUL(i,0) AND mousex<=Ctrl.TBoxLR(i,0) THEN
bx = Ctrl.TBoxX(i)+1 : by = Ctrl.TBoxY(i)+1
bw = Ctrl.TBoxWidth(i) : bt$ = Ctrl.TBoxText$(i)
CALL GetString(Ctrl.TBoxText$(i),bx,by,bw)
IF VAL(Ctrl.TBoxText$(i))>32768 THEN Ctrl.TBoxText$(i) = "32768"
IF VAL(Ctrl.TBoxText$(i))=0 THEN Ctrl.TBoxText$(i) = "1"
CALL SetTextBox(i) : GOSUB GetSeed
Ctrl.SwOnOff(0) = 0 : CALL AdjSwitch(0) 'auto seed off
END IF
END IF
NEXT
WHILE MOUSE(0) <> 0 : WEND 'wait for release (right half only)
END IF
IF Ctrl.BtnOnOff(0) = -1 THEN GOSUB DefSettings : GOSUB SetControls 'restore defaults
IF Ctrl.BtnOnOff(1) = -1 THEN GOSUB GenSeed : GOSUB SetSeed : Ctrl.SwOnOff(0) = 0 : CALL AdjSwitch(0)
GOTO CtrlLoop
'*** Subprograms ***
SUB DrawPot(PotNum%) STATIC
x% = (Ctrl.PotX(PotNum%)-1)*8 : y% = (Ctrl.PotY(PotNum%)-1)*8+9
Ctrl.PotUL(PotNum%,0) = x%+2 : Ctrl.PotUL(PotNum%,1) = y%+2
Ctrl.PotLR(PotNum%,0) = x%+298 : Ctrl.PotLR(PotNum%,1) = y%+8
LINE (x%-5,y%-11)-STEP(310,24),1,b
LINE (x%,y%)-STEP(300,10),2,bf
LOCATE Ctrl.PotY(PotNum%),Ctrl.PotX(PotNum%)
PRINT Ctrl.PotTitle$(PotNum%)
END SUB
'------
SUB AdjPot(PotNum%) STATIC
x% = Ctrl.PotUL(PotNum%,0) : y% = Ctrl.PotUL(PotNum%,1)
LINE (x%,y%)-STEP(296,6),1,bf
LINE (x%+Ctrl.PotValue(PotNum%),y%)-STEP(10,6),3,bf
END SUB
'------
SUB DrawSwitch(SwNum%) STATIC
x% = (Ctrl.SwX(SwNum%)+3)*8 : y% = (Ctrl.SwY(SwNum%)-1)*8+8
Ctrl.SwUL(SwNum%,0) = x%+2 : Ctrl.SwUL(SwNum%,1) = y%+2
Ctrl.SwLR(SwNum%,0) = x%+44 : Ctrl.SwLR(SwNum%,1) = y%+8
LINE (x%-36,y%-10)-STEP(118,22),1,b
LOCATE Ctrl.SwY(SwNum%),Ctrl.SwX(SwNum%) : PRINT Ctrl.SwTitle$(SwNum%)
LOCATE Ctrl.SwY(SwNum%)+1,Ctrl.SwX(SwNum%) : PRINT Ctrl.SwLab$(SwNum%)
LINE (x%,y%)-STEP(48,10),2,bf
END SUB
'------
SUB AdjSwitch(SwNum%) STATIC
x% = Ctrl.SwUL(SwNum%,0) : y% = Ctrl.SwUL(SwNum%,1)
LINE (x%,y%)-STEP(44,6),1,bf
IF Ctrl.SwOnOff(SwNum%) = -1 THEN Offset% = 0 :ELSE Offset% = 22
LINE (x%+Offset%,y%)-STEP(22,6),3,bf
END SUB
'------
SUB DrawButton(BtnNum%) STATIC
x% = (Ctrl.BtnX(BtnNum%)+7)*8+2 : y% = (Ctrl.BtnY(BtnNum%)-1)*8
Ctrl.BtnUL(BtnNum%,0) = x%+2 : Ctrl.BtnUL(BtnNum%,1) = y%+2
Ctrl.BtnLR(BtnNum%,0) = x%+42 : Ctrl.BtnLR(BtnNum%,1) = y%+15
LINE (x%-70,y%-2)-STEP(118,22),1,b
LOCATE Ctrl.BtnY(BtnNum%),Ctrl.BtnX(BtnNum%) : PRINT Ctrl.BtnTitle$(BtnNum%,0)
LOCATE Ctrl.BtnY(BtnNum%)+1,Ctrl.BtnX(BtnNum%) : PRINT Ctrl.BtnTitle$(BtnNum%,1)
LINE (x%,y%)-STEP(44,17),2,bf
END SUB
'------
SUB AdjButton(BtnNum%) STATIC
x% = Ctrl.BtnUL(BtnNum%,0) : y% = Ctrl.BtnUL(BtnNum%,1)
IF Ctrl.BtnOnOff(BtnNum%) = -1 THEN Colr% = 3 :ELSE Colr% = 1
LINE (x%,y%)-STEP(40,13),Colr%,bf
END SUB
'------
SUB DrawSelector(SelNum%) STATIC
x% = (Ctrl.SelX(SelNum%)-1)*8 : y% = (Ctrl.SelY(SelNum%)-1)*8+9
Ctrl.SelUL(SelNum%,0) = x%+2 : Ctrl.SelUL(SelNum%,1) = y%+2
Ctrl.SelLR(SelNum%,0) = x%+232 : Ctrl.SelLR(SelNum%,1) = y%+8
LINE (x%-4,y%-11)-STEP(238,24),1,b
LOCATE Ctrl.SelY(SelNum%),Ctrl.SelX(SelNum%) : PRINT Ctrl.SelTitle$(SelNum%)
LINE (x%,y%)-STEP(226,10),2,bf
SelWidth% = (226-3*(Ctrl.SelPosns(SelNum%)+1))/Ctrl.SelPosns(SelNum%) 'width of each button
FOR i% = 0 TO Ctrl.SelPosns(SelNum%)-1
LftEdge% = x%+3+i%*(SelWidth%+3)
LINE (LftEdge%,y%+2)-STEP(SelWidth%,6),1,bf
NEXT i%
END SUB
'------
SUB AdjSelector(SelNum%) STATIC
x% = Ctrl.SelUL(SelNum%,0) : y% = Ctrl.SelUL(SelNum%,1)
SelWidth% = (226-3*(Ctrl.SelPosns(SelNum%)+1))/Ctrl.SelPosns(SelNum%) 'width of each button
FOR i% = 0 TO Ctrl.SelPosns(SelNum%)-1
LftEdge% = x%+1+i%*(SelWidth%+3)
IF i%+1 = Ctrl.SelSetting(SelNum%) THEN Colr% = 3 :ELSE Colr% = 1
LINE (LftEdge%,y%)-STEP(SelWidth%,6),Colr%,bf
NEXT
END SUB
'------
SUB DrawTextBox(TBoxNum%) STATIC
x% = (Ctrl.TBoxX(TBoxNum%)-1)*8 : y% = (Ctrl.TBoxY(TBoxNum%)-1)*8+8
Ctrl.TBoxUL(TBoxNum%,0) = x% : Ctrl.TBoxUL(TBoxNum%,1) = y%
Ctrl.TBoxLR(TBoxNum%,0) = x%+226 : Ctrl.TBoxLR(TBoxNum%,1) = y%+9
LINE (x%-4,y%-11)-STEP(238,24),1,b
LOCATE Ctrl.TBoxY(TBoxNum%),Ctrl.TBoxX(TBoxNum%) : PRINT Ctrl.TBoxTitle$(TBoxNum%)
LINE (x%,y%)-STEP(226,9),2,bf
END SUB
'------
SUB SetTextBox(TBoxNum%) STATIC
x% = Ctrl.TBoxUL(TBoxNum%,0) : y% = Ctrl.TBoxUL(TBoxNum%,1)
LINE (x%,y%)-STEP(226,9),2,bf
COLOR 1,2
LOCATE Ctrl.TBoxY(TBoxNum%)+1,Ctrl.TBoxX(TBoxNum%)+1 : PRINT Ctrl.TBoxText$(TBoxNum%)
COLOR 1,0
END SUB
'*** GetString *** M. Steed *** 21-Sep-86 ***
SUB GetString (Text$,TextX%,TextY%,Length%) STATIC
'*** Collect an input string ***
Cursor% = 1
InText$ = Text$ 'Save a copy in case of cancel
GSPrintString:
Lngth% = LEN(Text$)
IF Lngth% > Length% THEN Text$ = LEFT$(Text$,Length%) : GOTO GSPrintString
IF Cursor% > Lngth%+1 THEN Cursor% = Lngth%+1
IF Cursor% < 1 THEN Cursor% = 1
CrsrChar$ = MID$(Text$,Cursor%,1) 'cursor
FirstPt$ = LEFT$(Text$,Cursor%-1) 'before cursor
LastPt$ = MID$(Text$,Cursor%+1,Length%) 'after cursor
LOCATE TextY%,TextX%
COLOR 1,2 : PRINT FirstPt$;
COLOR 2,3 : IF CrsrChar$ <> "" THEN PRINT CrsrChar$; :ELSE PRINT " "; : Lngth% = Lngth%+1 'compensate for blank cursor
COLOR 1,2 : PRINT LastPt$;
PRINT SPACE$(Length%-Lngth%+1)
GSGetChar:
Char$ = INKEY$
IF Char$ = "" THEN GSGetChar
IF Char$ = CHR$(13) THEN GSEnd 'Return
IF Char$ = CHR$(17) THEN Text$ = InText$ : Cursor% = 1 : GOTO GSPrintString 'CTL-Q restores initial
IF Char$ = CHR$(31) THEN Cursor% = Cursor%-1 : GOTO GSPrintString '<-
IF Char$ = CHR$(30) THEN Cursor% = Cursor%+1 : GOTO GSPrintString '->
IF Char$ = CHR$(24) THEN Text$ = "" : GOTO GSPrintString 'CTL-X Deletes all
IF Char$ = CHR$(127) THEN Text$ = FirstPt$ + LastPt$ : GOTO GSPrintString 'Delete deletes beneath
IF Char$ = CHR$(8) AND Cursor% > 1 THEN 'Backspace deletes to left
FirstPt$ = LEFT$(FirstPt$,LEN(FirstPt$)-1)
Text$ = FirstPt$ + CrsrChar$ + LastPt$
Cursor% = Cursor%-1 : GOTO GSPrintString
END IF
IF Char$ < "0" OR Char$ > "9" THEN GSGetChar
'add new char to string
Text$ = FirstPt$ + Char$ + CrsrChar$ + LastPt$
Cursor% = Cursor% +1 : GOTO GSPrintString
GSEnd:
LOCATE TextY%,TextX%
Lngth% = LEN(Text$)
COLOR 1,2 : PRINT Text$ + SPACE$(Length%-Lngth%+1)
END SUB
'*** String Requester *** M. Steed *** 14-Oct-86 ***
SUB StringReq (Message$,Text$,Yes$,No$,Xposn%,Yposn%,YesNo%) STATIC
DIM SaveBox%(2450) 'Init storage array
Size%=2
Cursor% = 1
Length% = 15*Size%
InText$ = Text$ 'Save a copy in case of cancel
IF No$="" THEN No$="Cancel"
Dummy% = MOUSE(0) 'clear initial 'hit'
'*** Create the Strings ***
TextX% = Xposn%/8 : TextY% = Yposn%/8
x% = TextX%*8 : y% = TextY%*8 'force box to align to text
TextX% = TextX%+2 : TextY% = TextY%+2 'offset for text
Message$ = LEFT$(Message$,Size%*16)
Yes$ = LEFT$(Yes$,Size%*6)
Yes$ = SPACE$((Size%*6-LEN(Yes$))/2)+Yes$ 'center Yes$
No$ = LEFT$(No$,Size%*6)
No$ = SPACE$((Size%*6-LEN(No$))/2)+No$ 'center No$
GET (x%,y%)-STEP(266,47),SaveBox% 'save the background
'*** Draw Requester ***
LINE (x%,y%)-STEP(266,47),1,bf 'main box
LINE (x%+1,y%+1)-STEP(264,45),2,b 'outline
LINE (x%+5,y%+16)-STEP(255,8),0,bf 'text box
LINE (x%+5,y%+29)-STEP(104,12),2,b 'yes box
LINE (x%+157,y%+29)-STEP(104,12),2,b 'no box
COLOR 0,1 'fill in the text
LOCATE TextY%,TextX% : PRINT Message$
LOCATE TextY%+3,TextX% : PRINT Yes$
LOCATE TextY%+3,TextX%+19 : PRINT No$
'*** Collect the String ***
TRPrintString:
Lngth% = LEN(Text$)
IF Lngth% > Length% THEN Text$ = LEFT$(Text$,Length%) : GOTO SRPrintString
IF Cursor% > Lngth%+1 THEN Cursor% = Lngth%+1
IF Cursor% < 1 THEN Cursor% = 1
CrsrChar$ = MID$(Text$,Cursor%,1) 'cursor
FirstPt$ = LEFT$(Text$,Cursor%-1) 'before cursor
LastPt$ = MID$(Text$,Cursor%+1,Length%) 'after cursor
LOCATE TextY%+1,TextX%
COLOR 1,0 : PRINT FirstPt$;
COLOR 0,3 : IF CrsrChar$ <> "" THEN PRINT CrsrChar$; :ELSE PRINT " "; : Lngth% = Lngth%+1 'compensate for blank cursor
COLOR 1,0 : PRINT LastPt$;
PRINT SPACE$(Length%-Lngth%+1)
TRGetChar:
IF MOUSE(0) <> 0 THEN TRClick 'check on mouse pos'n
Char$ = INKEY$
IF Char$ = "" THEN TRGetChar
IF Char$ = CHR$(13) THEN TRYesSel
IF Char$ = CHR$(17) THEN Text$ = InText$ : Lngth% = LEN(Text$) : GOTO TRPrintString 'CTL-Q cancels
IF Char$ = CHR$(31) THEN Cursor% = Cursor%-1 : GOTO TRPrintString '<-
IF Char$ = CHR$(30) THEN Cursor% = Cursor%+1 : GOTO TRPrintString '->
IF Char$ = CHR$(24) THEN Text$ = "" : GOTO TRPrintString 'CTL-X Deletes all
IF Char$ = CHR$(127) THEN Text$ = FirstPt$ + LastPt$ : GOTO TRPrintString 'Delete deletes beneath
IF Char$ = CHR$(8) AND Cursor% > 1 THEN 'Backspace deletes to left
FirstPt$ = LEFT$(FirstPt$,LEN(FirstPt$)-1)
Text$ = FirstPt$ + CrsrChar$ + LastPt$
Cursor% = Cursor%-1 : GOTO TRPrintString
END IF
IF Char$ < " " OR Char$ > "~" THEN TRGetChar
Text$ = FirstPt$ + Char$ + CrsrChar$ + LastPt$ 'add new char to string
Cursor% = Cursor%+1 : GOTO TRPrintString
TRClick:
mousex%=MOUSE(1) : mousey%=MOUSE(2) 'get mouse position
IF mousey% < y%+29 OR mousey% > y%+41 THEN TRPrintString
IF mousex% > x%+5 AND mousex% < x%+109 THEN TRYesSel
IF mousex% > x%+157 AND mousex% < x%+261 THEN TRNoSel
GOTO TRPrintString
TRYesSel: 'Yes box selected
YesNo% = -1
LINE (x%+6,y%+30)-STEP(102,10),3,bf 'color box
COLOR 0,3 : LOCATE TextY%+3,TextX% : PRINT Yes$ 'replace text
GOTO TREnd
TRNoSel: 'No box selected
YesNo% = 0
LINE (x%+158,y%+30)-STEP(102,10),3,bf 'color box
COLOR 0,3 : LOCATE TextY%+3,TextX%+19 : PRINT No$ 'replace text
TREnd:
LOCATE TextY%+1,TextX%
Lngth% = LEN(Text$)
COLOR 1,0 : PRINT Text$ + SPACE$(Length%-Lngth%+1)
FOR i% = 0 TO 500 : NEXT i% 'brief delay
PUT (x%,y%),SaveBox%,PSET 'restore the background
ERASE SaveBox%
END SUB
'*** Yes/No Requester *** M. Steed *** 14-Oct-86 ***
SUB YesNoReq (Message$,Yes$,No$,Xposn%,Yposn%,YesNo%) STATIC
DIM SaveBox%(2450) 'Init storage array
Size% = 2
Ybox% = 0
Dummy% = MOUSE(0) 'clear initial 'hit'
'*** Create the Strings ***
TextX% = Xposn%/8 : TextY% = Yposn%/8
x% = TextX%*8 : y% = TextY%*8 'force box to align to text
TextX% = TextX%+2 : TextY% = TextY%+2 'offset for text
Delim% = INSTR(Message$,"|") 'create the print strings
IF Delim% THEN
FirstLn$ = LEFT$(Message$,Delim%-1) : SecndLn$ = MID$(Message$,Delim%+1)
ELSE
FirstLn$ = Message$ : SecndLn$=""
END IF
FirstLn$ = LEFT$(FirstLn$,Size%*16)
IF Delim% THEN SecndLn$ = LEFT$(SecndLn$,Size%*16)
IF Yes$<>"" THEN
Ybox% = -1
Yes$ = LEFT$(Yes$,Size%*6)
Yes$ = SPACE$((Size%*6-LEN(Yes$))/2)+Yes$ 'center Yes$
END IF
No$ = LEFT$(No$,Size%*6)
No$ = SPACE$((Size%*6-LEN(No$))/2)+No$ 'center No$
GET (x%,y%)-STEP(266,47),SaveBox% 'save the background
'*** Draw Requester ***
LINE (x%,y%)-STEP(266,47),1,bf 'main box
LINE (x%+1,y%+1)-STEP(264,45),2,b 'outline
IF Ybox% THEN LINE (x%+5,y%+29)-STEP(104,12),2,b 'yes box (if present)
LINE (x%+157,y%+29)-STEP(104,12),2,b 'no box
COLOR 0,1 'fill in the text
LOCATE TextY%,TextX% : PRINT FirstLn$
LOCATE TextY%+1,TextX% : PRINT SecndLn$
IF Ybox% THEN LOCATE TextY%+3,TextX% : PRINT Yes$
LOCATE TextY%+3,TextX%+19 : PRINT No$
COLOR 0,3 'set colors for mouse select
YNMonMouse:
WHILE MOUSE(0)=0 'wait 'till the button is clicked
WEND
mousex%=MOUSE(1) : mousey%=MOUSE(2) 'get mouse position
IF mousey% < y%+29 OR mousey% > y%+41 THEN YNMonMouse
IF (mousex% > x%+5 AND mousex% < x%+109) AND Ybox% THEN YNYesSel
IF mousex% > x%+157 AND mousex% < x%+261 THEN YNNoSel
GOTO YNMonMouse
YNYesSel: 'Yes box selected
YesNo% = -1
LINE (x%+6,y%+30)-STEP(102,10),3,bf 'color box
LOCATE TextY%+3,TextX% : PRINT Yes$ 'replace text
GOTO YNDelay
YNNoSel: 'No box selected
YesNo% = 0
LINE (x%+158,y%+30)-STEP(102,10),3,bf 'color box
LOCATE TextY%+3,TextX%+19 : PRINT No$ 'replace text
YNDelay: 'delay before returning
FOR i% = 0 TO 500 : NEXT i%
PUT (x%,y%),SaveBox%,PSET 'restore the background
ERASE SaveBox%
COLOR 1,0
END SUB