home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
AMOS PD CD
/
amospdcd.iso
/
sourcecode
/
general
/
art_proggy.amos
/
art_proggy.amosSourceCode
next >
Encoding:
Amiga
Atari
Commodore
DOS
FM Towns/JPY
Macintosh
Macintosh JP
Macintosh to JP
NeXTSTEP
RISC OS/Acorn
Shift JIS
UTF-8
Wrap
AMOS Source Code
|
1993-01-07
|
38.2 KB
|
1,933 lines
'
' ** THIS ART PROGRAM WORKS, EXCEPT FOR THE UNDO FEATURE, AND A LOT OF
' ** BUGS THAT HAVE NOT BEEN SORTED YET.
'
' ** TO VIEW A PICTURE THAT HAS BEEN LOADED, SELECT A DRAW-TOOL, TO GET
' ** THE BUTTON SCREEN BACK UP, PRESS <SPACE-BAR>.
'
Global XX,YY,OK,AN,P$,CLRS,REZ,NT,WD,HT,TIM,MK,FC,BC,T$,TEK,OUT,SHA,SF,FP,LP
Dim LLI(5)
Global RR,GG,BB,LLI(),R$,G$,B$,SCI,SPO,ICO,WDH,DENS,REZ$
T$="Written By John.A.Kinsella"
Get Rom Fonts
LLI(0)=%1111111111111111
LLI(1)=%1100110011001100
LLI(2)=%1010101010101010
LLI(3)=%1111011011110110
LLI(4)=%1100110011001100
LLI(5)=%1111111100000000
WDH=20
DENS=20
SPO=0
ICO=0
FP=0
LP=0
SF=1
OUT=0
SHA=0
FC=1
BC=0
CLRS=32
REZ=Lowres
REZ$="Low"
NT=0
WD=320
HT=200
TIM=1
Screen Open 1,WD,(HT+NT)*TIM,CLRS,REZ
Curs Off
Flash Off
Cls 0
Unpack 10 To 0
M[2]
SHOC
Screen Open 3,640,11,4,Hires
Curs Off
Flash Off
Get Palette 0
Screen Display 3,,160,,
TC[""]
SC[1]
RGB[FC]
SLID[1,RR]
SLID[2,GG]
SLID[3,BB]
SC[0]
GST
ST
SPAT[0]
Ink 6,7
Bar 312,6 To 327,21
SLIN[0]
Draw 313,26 To 326,39
SEL[CLRS]
SC[0]
PSI[0]
PSI[1]
Procedure G[N]
Gr Writing N
End Proc
Procedure RER
SC[0]
SF[0]
SF[3]
SF[4]
G[1]
End Proc
Procedure SEL[N]
Screen Open 4,320,10,N,Lowres
Curs Off
Flash Off
Screen Display 4,,171,,
Get Palette 1
QWE=0
HH=10
If N>31
HH=4
N=31
OK3=1
End If
For X1=0 To 320 Step 320/N
Ink QWE
Bar X1,0 To X1+(320/N),HH
Inc QWE
Next
If OK3=1
QWE=32
For X1=0 To 320 Step 320/N
Ink QWE
Bar X1,5 To X1+(320/N),10
Inc QWE
Next
End If
End Proc
Procedure GST
R$=Hex$(RR)
G$=Mid$(Hex$(GG),2,1)
B$=Mid$(Hex$(BB),2,1)
End Proc
Procedure TC[N$]
SC[3]
Ink 3,2
Cls 2
B[0,0,639,10,N$,1]
SC[0]
End Proc
Procedure SHOC
SC[1]
N1=Colour(FC)
N2=Colour(BC)
SC[0]
Colour 6,N1
Colour 7,N2
End Proc
Procedure FLIP[Z]
SC[1]
W=Screen Width
H=Screen Height/2
Get Block 1,0,0,W-1,H-1
Get Block 2,0,H,W-1,H
If Z=0
Hrev Block 1
Hrev Block 2
Put Block 1,0,0
Put Block 2,0,H
End If
If Z=1
Vrev Block 1
Vrev Block 2
Put Block 2,0,0
Put Block 1,0,H+1
End If
Del Block 1
Del Block 2
SC[0]
End Proc
Procedure RGB[N]
RR=Colour(N)/256
GG=Colour(N)/16 mod 16
BB=Colour(N) mod 16
End Proc
Procedure SPAT[N]
Set Pattern N
End Proc
Procedure SLIN[N]
Set Line LLI(N)
End Proc
Procedure MKY
MK=Mouse Key
End Proc
Procedure BL
Bell 96
End Proc
Procedure XY
XX=X Screen(X Mouse)
YY=Y Screen(Y Mouse)
End Proc
Procedure YX
XX=X Mouse
YY=Y Mouse
End Proc
Procedure B[X1,Y1,X2,Y2,A$,IN]
If IN=1
C1=1
C2=3
Else
C1=3
C2=1
End If
Ink 2
Bar X1,Y1 To X2,Y2
Ink C1
Polyline X2,Y1 To X1,Y1 To X1,Y2
Ink C2
Polyline X1,Y2 To X2,Y2 To X2,Y1+1
If A$<>""
WID=Text Length(A$)
Ink 3,2
X7=(((X2-X1)/2)+X1)-(WID/2)
Text X7,((Y2-Y1)/2)+Y1+3,A$
End If
End Proc
Procedure R[X1,Y1,X2,Y2,N]
AN=0
XY
X4=XX
Y4=YY
If X4<X1 or X4>X2 or Y4<Y1 or Y4>Y2
Pop Proc
End If
G[2]
While Mouse Key>0
XY
MKY
X4=XX
Y4=YY
If X4>X1 and X4<X2 and Y4>Y1 and Y4<Y2 and AN=0
Bar X1,Y1 To X2,Y2
AN=MK
End If
If AN
If X4<X1 or X4>X2 or Y4<Y1 or Y4>Y2
Bar X1,Y1 To X2,Y2
AN=0
End If
End If
Wend
If AN>0 and N=0
Bar X1,Y1 To X2,Y2
End If
G[1]
End Proc
Procedure E[X$,L]
Screen Open 7,640,26,4,Hires
Curs Off
Flash Off
Cls 2
Screen Display 7,,150,,
Palette $0,$EEE,$AA6,$222
QQ=(Len(X$)*8)/2
W=Screen Width/2
PP=(L*8)/2
B[(W-PP)-8,11,(W+PP)+8,24,"",1]
B[320-QQ-5,1,320+QQ+5,10,X$,1]
OK=0
P$=""
While OK=0
Cls 2,W-PP,12 To W+PP,23
Ink 3,2
Text W-(Len(P$)*8)/2,20,P$
W$=""
While W$=""
W$=Inkey$
Wend
If W$=Chr$(8) and Len(P$)>0
P$=Left$(P$,Len(P$)-1)
W$=""
End If
If W$=Chr$(13)
OK=1
End If
If Asc(W$)>31 and Len(P$)<L
P$=P$+W$
End If
Wend
Screen Close 7
End Proc
Procedure SC[N]
Screen N
End Proc
Procedure SF[N]
Screen To Front N
End Proc
Procedure M[N]
Change Mouse N
End Proc
Procedure SLID[N,P]
Ink 2
Z=81-(P*5)
If N=1
Bar 360,6 To 369,86
Screen Copy 0,406,65,414,70 To 0,361,Z
End If
If N=2
Bar 371,6 To 380,86
Screen Copy 0,406,65,414,70 To 0,372,Z
End If
If N=3
Bar 382,6 To 391,86
Screen Copy 0,406,65,414,70 To 0,383,Z
End If
End Proc
Procedure ST
SC[0]
SF[0]
Ink 3,2
Text 360,99,R$+G$+B$
Text 421,99," "
Text 421,99,Str$(FC)-" "
End Proc
Procedure SCLN
YX
SCI=Scin(XX,YY)
End Proc
Do
SCLN
CHK[34,108]
If OK=1 and SCI=0
Q1
End If
CHK[116,178]
If OK=1 and SCI=0
Q2
End If
CHK[186,254]
If OK=1 and SCI=0
Q3
End If
CHK[262,343]
If OK=1 and SCI=0
Q4
End If
CHK[351,444]
If OK=1 and SCI=0
Q5
End If
CHK[452,515]
If OK=1 and SCI=0
Q6
End If
CHK[523,604]
If OK=1 and SCI=0
Q7
End If
If SCI=4
While SCI=4
SCLN
MKY
SC[4]
XY
If MK=1 and YY>0 and YY<Screen Height
SC[4]
FC=Point(XX,YY)
RGB[FC]
SC[0]
SLID[1,RR]
SLID[2,GG]
SLID[3,BB]
GST
ST
SHOC
End If
If MK=2
SC[4]
BC=Point(XX,YY)
SHOC
End If
Wend
End If
SC[0]
Loop
Procedure CHK[X1,X2]
OK=0
XY
If XX>X1 and XX<X2
OK=1
End If
End Proc
' Disk Op
Procedure Q1
Do
SCLN
CHK[34,108]
If OK=0 or SCI>0
Pop Proc
End If
R[37,5,105,13,0]
If AN>0
If AN=1
F$=Fsel$("","","Load IFF Picture")
End If
If AN=2
E["Load IFF Picture",60]
F$=P$
End If
If F$=""
Pop Proc
End If
If Not Exist(F$)
Pop Proc
End If
M[3]
TC["Loading IFF Picture..."]
Load Iff F$,1
CLRS=Screen Colour
FC=1
BC=0
RGB[FC]
GST
ST
BL
SEL[CLRS]
RER
SHOC
SLID[1,RR]
SLID[2,GG]
SLID[3,BB]
M[2]
TC[""]
End If
R[37,15,105,23,0]
If AN>0
If AN=1
F$=Fsel$("","","Load ABK Picture")
End If
If AN=2
E["Load ABK Picture",60]
F$=P$
End If
If F$=""
Pop Proc
End If
If Not Exist(F$)
Pop Proc
End If
M[3]
TC["Loading ABK Picture..."]
Load F$,6
TC["Unpacking Picture..."]
Unpack 6 To 1
CLRS=Screen Colour
Erase 6
FC=1
BC=0
RGB[FC]
GST
ST
BL
SEL[CLRS]
RER
SHOC
SLID[1,RR]
SLID[2,GG]
SLID[3,BB]
M[2]
TC[""]
End If
R[37,25,105,33,0]
If AN>0
If AN=1
F$=Fsel$("","","Save IFF Picture")
End If
If AN=2
E["Save IFF Picture",60]
F$=P$
End If
If F$=""
Pop Proc
End If
If Exist(F$)
E["File Already Exist's, Overwrite",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
End If
M[3]
TC["Saving IFF Picture..."]
SC[1]
Save Iff F$,0
BL
SC[0]
M[2]
TC[""]
End If
R[37,35,105,43,0]
If AN>0
If AN=1
F$=Fsel$("","","Save ABK Picture")
End If
If AN=2
E["Save ABK Picture",60]
F$=P$
End If
If F$=""
Pop Proc
End If
If Exist(F$)
E["File Already Exist's, Overwrite",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
End If
M[3]
TC["Compacting ABK Picture..."]
Spack 1 To 6
TC["Saving ABK Picture..."]
Save F$,6
Erase 6
BL
SC[0]
M[2]
TC[""]
End If
R[37,45,105,53,0]
If AN>0
If AN=1
F1$=Fsel$("","","File To Rename")
End If
If AN=2
E["File To Rename",60]
F1$=P$
End If
If F1$=""
Pop Proc
End If
If Not Exist(F1$)
Pop Proc
End If
If AN=1
F2$=Fsel$("","","Rename File To")
End If
If AN=2
E["Rename File To",60]
F2$=P$
End If
If F2$=""
Pop Proc
End If
If Exist(F2$)
Pop Proc
End If
E["Sure (Y/N) ?",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
M[3]
Rename F1$ To F2$
BL
M[2]
End If
R[37,55,105,63,0]
If AN>0
If AN=1
F$=Fsel$("","","File To Delete")
End If
If AN=2
E["File To Delete",60]
F$=P$
End If
If F$=""
Pop Proc
End If
If Not Exist(F$)
Pop Proc
End If
E["Sure (Y/N) ?",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
M[3]
Kill F$
BL
M[2]
End If
R[37,65,105,73,0]
If AN>0
If AN=1
F$=Fsel$("","","Directory To Create")
End If
If AN=2
E["Directory To Create",60]
F$=P$
End If
If F$=""
Pop Proc
End If
If Exist(F$)
Pop Proc
End If
E["Sure (Y/N) ?",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
M[3]
Mkdir F$
BL
M[2]
End If
R[37,75,105,83,0]
If AN>0
E["Enter Drive Title e.g DF1: MyDisk: Etc!",40]
If Exist(P$)
Dir$=P$
TC["Free Disk Space In "+P$+" Is"+Str$(Dfree)+" Bytes"]
Dir$="ram:"
End If
End If
R[37,85,105,93,0]
If AN>0
Q1$="Chip Mem:"+Str$(Chip Free)+" Fast Mem:"+Str$(Fast Free)
Q1$=Q1$+" Sprites:"+Str$(Length(1))+" Icons:"+Str$(Length(2))
TC[Q1$]
End If
Loop
End Proc
' Screen
Procedure Q2
Do
SCLN
CHK[116,178]
If OK=0 or SCI>0
Pop Proc
End If
R[119,5,175,13,0]
If AN>0
REZ=Lowres
REZ$="Low"
WD=320
HT=200
End If
R[119,15,175,23,0]
If AN>0
If CLRS>16
CLRS=16
End If
REZ=Hires
REZ$="Medium"
WD=640
HT=200
End If
R[119,25,175,33,0]
If AN>0
REZ=Lowres+Laced
REZ$="Interlace"
WD=320
HT=200
TIM=2
End If
R[119,35,175,43,0]
If AN>0
If CLRS>16
CLRS=16
End If
REZ=Hires+Laced
REZ$="High"
WD=640
HT=200
TIM=2
End If
R[120,45,134,53,0]
If AN>0
CLRS=2
End If
R[140,45,154,53,0]
If AN>0
CLRS=4
End If
R[160,45,174,53,0]
If AN>0
CLRS=8
End If
R[120,55,134,63,0]
If AN>0
CLRS=16
End If
R[140,55,154,63,0]
If AN>0
CLRS=32
End If
R[160,55,174,63,0]
If AN>0
CLRS=64
End If
R[120,65,174,73,0]
If AN>0
CLRS=4096
End If
R[120,75,146,83,0]
If AN>0
NT=56
End If
R[148,75,174,83,0]
If AN>0
NT=0
End If
R[120,85,174,103,0]
If AN>0
If REZ=Hires and CLRS>16
CLRS=16
End If
If REZ=Hires+Laced and CLRS>16
CLRS=16
End If
Screen Open 1,WD,(HT+NT)*TIM,CLRS,REZ
Curs Off
Flash Off
Cls 0
SEL[CLRS]
RER
SHOC
BL
Q1$="Screen ( Width:"+Str$(WD)+" Height:"
Q1$=Q1$+Str$((HT+NT)*TIM)+" Colours:"+Str$(CLRS)
Q1$=Q1$+" Resolution: "+REZ$+" )"
TC[Q1$]
End If
Loop
End Proc
' Font
Procedure Q3
Do
SCLN
CHK[186,254]
If OK=0 or SCI>0
Pop Proc
End If
R[189,5,251,13,0]
If AN>0
SC[1]
Set Font SF
SC[0]
BL
End If
R[189,15,251,23,0]
If AN>0
E["Enter Text",80]
T$=P$
End If
R[189,25,251,33,0]
If AN>0
SC[1]
SF[1]
Set Text TEK
G[2]
Do
XY
MKY
If MK=1
A1=FC
A2=BC
End If
If MK=2
A1=BC
A2=BC
End If
Text XX,YY,T$
Wait Vbl
Text XX,YY,T$
If MK>0
G[0]
If OUT=1 and SHA=1
OK2=1
Else
OK2=0
End If
If OUT=1
Ink A2
Text XX+1,YY,T$
Text XX-1,YY,T$
Text XX,YY-1,T$
Text XX,YY+1,T$
If OK2=1
Text XX+1+1,YY+1,T$
Text XX+1-1,YY+1,T$
Text XX+1,YY+1-1,T$
Text XX+1,YY+1+1,T$
End If
End If
If SHA=1 and OK2=0
Ink A2
Text XX+1,YY+1,T$
End If
Ink A1,A2
Text XX,YY,T$
G[2]
End If
If Inkey$=" "
BL
RER
Exit
End If
Loop
End If
R[189,35,205,46,1]
If AN>0
Bchg 1,TEK
OK=1
End If
R[212,35,228,46,1]
If AN>0
Bchg 2,TEK
OK=1
End If
R[235,35,251,46,1]
If AN>0
Bchg 0,TEK
OK=1
End If
If OK=1
SC[1]
Set Text TEK
SC[0]
OK=0
End If
R[200,48,216,59,1]
If AN>0
If OUT=1
OUT=0
Else
OUT=1
End If
End If
R[224,48,240,59,1]
If AN>0
If SHA=1
SHA=0
Else
SHA=1
End If
End If
R[189,61,218,71,0]
If AN>0 and SF>1
Dec SF
OK3=1
End If
R[222,61,251,71,0]
If Font$(SF+1)<>"" and AN>0
Inc SF
OK3=1
End If
If OK3=1
TC[Font$(SF)]
OK3=0
End If
Loop
End Proc
' Effects
Procedure Q4
Do
SCLN
CHK[262,343]
If OK=0 or SCI>0
Pop Proc
End If
R[330,5,340,12,0]
If AN>0 and FP<35
Inc FP
OK3=1
End If
R[330,15,340,22,0]
If AN>0 and FP>0
Dec FP
OK3=1
End If
If OK3=1
SPAT[FP]
Ink 6,7
Bar 312,6 To 327,21
SPAT[0]
OK3=0
End If
R[330,24,340,31,0]
If AN>0 and LP<5
Inc LP
OK4=1
End If
R[330,34,340,41,0]
If AN>0 and LP>0
Dec LP
OK4=1
End If
If OK4=1
SLIN[LP]
Ink 6,7
Draw 313,26 To 326,39
SLIN[0]
OK4=0
End If
R[266,43,340,55,0]
If AN>0
FLIP[0]
End If
R[266,57,340,69,0]
If AN>0
FLIP[1]
End If
R[266,71,340,88,0]
If AN>0
E["Enter Degrees To Rotate (1 To 359 e.g 45.2)",5]
A#=Val(P$)
If P$=""
SC[0]
Pop Proc
End If
If A#<1 or A#>359
Pop Proc
End If
SC[1]
SF[1]
G[2]
Repeat
MKY
Until MK>0
XY
X1=XX
Y1=YY
Repeat
XY
X2=XX
Y2=YY
MKY
Box X1,Y1 To X2,Y2
Box X1,Y1 To X2,Y2
Until MK=0
Plot X1,Y1
G[1]
XS=X2-X1
YS=Y2-Y1
Z=Sqr(XS*XS+YS*YS)
Screen Open 2,Z+(3*XS),Z+(3*YS),Screen Colour,Lowres
Curs Off
Flash Off
Cls 0
Get Palette 1
XRS=XS
YRS=YS
SC[2]
A#=A#/180.0*Pi#
G#=(A#+Pi#/4.0)
X=Cos(G#)*64
Y=Sin(G#)*64
XOF=80-X
YOF=68-Y
LX=XOF
LY=YOF
HX=XOF
HY=YOF
SC[1]
For X#=1 To XRS Step 0.7
For Y#=1 To YRS Step 0.7
P=Point(X#+X1,Y#+Y1)
If P>0
R#=Sqr(X#*X#+Y#*Y#)
Q#=Acos(X#/R#)
X=XOF+Cos(Q#+A#)*R#
LX=Min(X,LX)
HX=Max(X,HX)
Y=YOF+Sin(Q#+A#)*R#
LY=Min(Y,LY)
HY=Max(Y,HY)
Screen Copy 1,X#+X1,Y#+Y1,(X#+X1)+1,(Y#+Y1)+1 To 2,X,Y
End If
If Inkey$=Chr$(27)
BL
Screen Close 2
SC[0]
SF[0]
Direct
End If
Next
Next
DX=HX-LX
DY=HY-LY
SC[2]
Get Bob Length(1)+1,LX-1,LY-1 To LX+DX+1,LY+DY+1
Screen Close 2
SPO=Length(1)
PSI[0]
RER
End If
Loop
End Proc
' Palette
Procedure Q5
Do
SCLN
CHK[351,444]
If OK=0
Pop Proc
End If
If FC>31
FC=FC-32
OK8=1
End If
If BC>31
BC=BC-32
OK9=1
End If
XY
MKY
If XX>359 and XX<369 and YY>5 and YY<87 and MK>0
RR=(90-(YY+6))/5
SLID[1,RR]
OK6=1
End If
If XX>370 and XX<381 and YY>5 and YY<87 and MK>0
GG=(90-(YY+6))/5
SLID[2,GG]
OK6=1
End If
If XX>381 and XX<392 and YY>5 and YY<87 and MK>0
BB=(90-(YY+6))/5
SLID[3,BB]
OK6=1
End If
If OK6=1
R$=Hex$(RR)
G$=Mid$(Hex$(GG),2,1)
B$=Mid$(Hex$(BB),2,1)
SC[1]
Colour FC,Val(R$+G$+B$)
SHOC
SC[4]
Colour FC,Val(R$+G$+B$)
SC[1]
OK6=0
ST
End If
R[417,46,441,65,0]
If AN>0
SC[1]
SF[1]
MKY
While MK=0
MKY
XY
Wend
FC=Point(XX,YY)
RGB[FC]
SHOC
RER
SLID[1,RR]
SLID[2,GG]
SLID[3,BB]
GST
ST
End If
R[417,68,441,87,0]
If AN>0
SC[1]
SF[1]
MKY
While MK=0
MKY
XY
Wend
BC=Point(XX,YY)
SHOC
RER
End If
R[403,5,441,13,0]
If AN>0
TC["Select Another Colour To Spread To"]
SC[4]
MKY
While MK=0
MKY
Wend
XY
TC=FC
E=Point(XX,YY)
For A=TC+1 To E-1
CDIF=E-A+1
RDIF=((Colour(E) and 3840)/256)-((Colour(A-1) and 3840)/256)
RA=((Colour(A-1) and 3840)/256)+(RDIF/CDIF)
GDIF=((Colour(E) and 240)/16)-((Colour(A-1) and 240)/16)
GA=((Colour(A-1) and 240)/16)+(GDIF/CDIF)
BDIF=(Colour(E) and 15)-(Colour(A-1) and 15)
BA=(Colour(A-1) and 15)+(BDIF/CDIF)
Colour A,(RA*256+GA*16+BA)
Next
SC[1]
Get Palette 4
SC[0]
SHOC
TC[""]
End If
R[403,15,441,23,0]
If AN>0
TC["Select Another Colour To Copy To"]
SC[4]
MKY
While MK=0
MKY
Wend
XY
E=Point(XX,YY)
Colour(E),Colour(FC)
SC[1]
Get Palette 4
SHOC
TC[""]
End If
R[403,25,441,33,0]
If AN>0
TC["Select Another Colour To Swap With"]
SC[4]
MKY
While MK=0
MKY
Wend
XY
A2=Point(XX,YY)
TC=Colour(FC)
Colour(FC),Colour(A2)
Colour(A2),TC
SC[1]
Get Palette 4
SHOC
TC[""]
End If
R[403,35,421,43,0]
If AN>0 and Length(1)>0
E["Get Sprite Palette SURE? (Y/N), Can't Undo!",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
SC[1]
Get Sprite Palette
SC[4]
Get Palette 1
SHOC
End If
R[423,35,441,43,0]
If AN>0 and Length(2)>0
E["Get Icon Palette SURE? (Y/N), Can't Undo!",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
SC[1]
Get Icon Palette
SC[4]
Get Palette 1
SHOC
End If
If OK8=1
FC=FC+32
End If
If OK9=1
BC=BC+32
End If
Loop
End Proc
' Tools
Procedure Q6
Do
SCLN
CHK[452,515]
If OK=0 or SCI>0
Pop Proc
End If
R[455,5,467,16,0]
If AN>0
SC[1]
SF[1]
Do
If Inkey$=" "
RER
Pop Proc
End If
MKY
If MK>0
If MK=1
A1=FC
A2=BC
Else
A1=BC
A2=BC
End If
Ink A1,A2
Repeat
XY
MKY
Plot XX,YY
Until MK=0
End If
Loop
End If
R[455,18,467,29,0]
If AN>0
SC[1]
SF[1]
Do
If Inkey$=" "
RER
Pop Proc
End If
MKY
If MK>0
If MK=1
A1=FC
A2=BC
Else
A1=BC
A2=BC
End If
Ink A1,A2
XY
X1=XX
Y1=YY
Repeat
XY
MKY
Draw X1,Y1 To XX,YY
X1=XX
Y1=YY
Until MK=0
End If
Loop
End If
R[455,31,467,42,0]
If AN>0
SC[1]
SF[1]
Do
If Inkey$=" "
RER
Pop Proc
End If
MKY
If MK>0
If MK=1
A1=FC
A2=BC
Else
A1=BC
A2=BC
End If
G[2]
XY
X1=XX
Y1=YY
Repeat
MKY
XY
Draw X1,Y1 To XX,YY
Draw X1,Y1 To XX,YY
Until MK=0
G[1]
Ink A1,A2
SLIN[LP]
Draw X1,Y1 To XX,YY
SLIN[0]
End If
Loop
End If
R[455,44,467,55,0]
If AN>0
SC[1]
SF[1]
Do
If Inkey$=" "
RER
Pop Proc
End If
MKY
If MK>0
If MK=1
A1=FC
A2=BC
Else
A1=BC
A2=BC
End If
G[2]
XY
X1=XX
Y1=YY
Repeat
MKY
XY
Box X1,Y1 To XX,YY
Wait Vbl
Box X1,Y1 To XX,YY
Until MK=0
G[1]
Ink A1,A2
SLIN[LP]
Box X1,Y1 To XX,YY
SLIN[0]
End If
Loop
End If
R[455,57,467,68,0]
If AN>0
SC[1]
SF[1]
Do
If Inkey$=" "
RER
Pop Proc
End If
MKY
If MK>0
If MK=1
A1=FC
A2=BC
Else
A1=BC
A2=BC
End If
G[2]
XY
X1=XX
Y1=YY
Repeat
MKY
XY
Box X1,Y1 To XX,YY
Wait Vbl
Box X1,Y1 To XX,YY
Until MK=0
G[1]
Ink A1,A2
If X1>XX
T=X1
X1=XX
XX=T
End If
If Y1>YY
T=Y1
Y1=YY
YY=T
End If
If X1=XX
XX=XX+2
End If
If Y1=YY
YY=YY+2
End If
SPAT[FP]
Bar X1,Y1 To XX,YY
SPAT[0]
End If
Loop
End If
R[470,5,482,16,0]
If AN>0
OK0=1
End If
R[470,18,482,29,0]
If AN>0
OK0=2
End If
If OK0>0
SC[1]
SF[1]
Do
If Inkey$=" "
RER
OK0=0
Pop Proc
End If
MKY
If MK>0
If MK=1
A1=FC
A2=BC
Else
A1=BC
A2=BC
End If
XY
X2=XX
Y2=YY
X1=X2
Y1=Y2
G[2]
Repeat
XY
MKY
R1=XX-X1+1
If R1<1
R1=1
End If
R2=YY-Y1+1
If R2<1
R2=1
End If
Ellipse X1,Y1,R1,R2
Ellipse X1,Y1,R1,R2
Until MK=0
G[1]
Ink A1,A2
If OK0=1
Ellipse X1,Y1,R1,R2
End If
If OK0=2
FDX=X1-R1
FDY=Y1-R2
RX=Max(1,Abs(X1-FDX))
RY=Max(1,Abs(Y1-FDY))
X1O=X1
Y1O=Y1
S#=0.1
If RX+RY<16
S#=0.5
End If
SPAT[FP]
For Q#=0 To 6.59734 Step S#
Polygon X1O,Y1O To X1,Y1 To X1+RX*Cos(Q#),Y1+RY*Sin(Q#)
X1O=X1+RX*Cos(Q#)
Y1O=Y1+RY*Sin(Q#)
Next
SPAT[0]
End If
End If
Loop
OK0=0
End If
R[470,31,482,42,0]
If AN=1
SC[1]
SF[1]
Do
If Inkey$=" "
RER
Pop Proc
End If
MKY
If MK=1
A1=FC
A2=BC
End If
If MK=2
A1=BC
A2=BC
End If
If MK>0
Ink A1,A2
Repeat
MKY
XY
If Rnd(DENS)=(DENS)
Plot(XX-Rnd(WDH)/2)+Rnd(WDH),(YY-Rnd(WDH)/2)+Rnd(WDH)
End If
Until MK=0
End If
Loop
End If
If AN=2
E["Enter Spray Size (1-640)",3]
If P$=""
Pop Proc
End If
X1=Val(P$)
If X1<1 or X1>640
Pop Proc
End If
WDH=X1
E["Enter Spray Density (1-50)",2]
If P$=""
Pop Proc
End If
X1=Val(P$)
If X1<1 or X1>50
Pop Proc
End If
DENS=X1
End If
R[455,70,467,81,0]
If AN>0
SC[1]
SF[1]
Do
If Inkey$=" "
RER
Pop Proc
End If
MKY
XY
If MK=1
Ink FC,BC
SPAT[FP]
Paint XX,YY
SPAT[0]
End If
If MK=2
Ink BC,BC
Paint XX,YY
End If
Loop
End If
R[470,44,482,55,0]
If AN>0
SC[1]
SF[1]
G[2]
Do
If Inkey$=" "
RER
G[1]
Pop Proc
End If
MKY
XY
If MK=1
X1=XX
Y1=YY
Repeat
XY
MKY
Box X1,Y1 To XX,YY
Box X1,Y1 To XX,YY
Until MK=0
If X1=XX
X1=X1-2
End If
If Y1=YY
Y1=Y1-2
End If
Get Bob Length(1)+1,X1,Y1 To XX,YY
SPO=Length(1)
PSI[0]
End If
If MK=2
X1=XX
Y1=YY
Repeat
XY
MKY
Box X1,Y1 To XX,YY
Box X1,Y1 To XX,YY
Until MK=0
If X1=XX
X1=X1-2
End If
If Y1=YY
Y1=Y1-2
End If
Get Bob Length(1)+1,X1,Y1 To XX,YY
G[1]
Ink BC,BC
Bar X1,Y1 To XX,YY
SPO=Length(1)
PSI[0]
End If
Loop
End If
R[470,70,482,81,0]
If AN>0
SC[1]
SF[1]
XY
Repeat
XY
MKY
Until MK>0
X1=XX
Y1=YY
Do
If Inkey$=" "
RER
Pop Proc
End If
MKY
XY
If MK=1
SLIN[LP]
Ink FC,BC
Draw X1,Y1 To XX,YY
End If
If MK=2
Ink BC,BC
Draw X1,Y1 To XX,YY
End If
Loop
End If
R[455,83,512,95,0]
If AN>0
SC[1]
SF[1]
Repeat
MKY
XY
Until MK>0
X1=XX
Y1=YY
G[2]
Repeat
XY
MKY
Box X1,Y1 To XX,YY
Box X1,Y1 To XX,YY
Until MK=0
X2=XX
Y2=YY
If X2<=X1 or Y2<=Y1
RER
Pop Proc
End If
Repeat
MKY
XY
Until MK>0
X3=XX
Y3=YY
Repeat
XY
MKY
Box X3,Y3 To XX,YY
Box X3,Y3 To XX,YY
Until MK=0
X4=XX
Y4=YY
If X4<=X3 or Y4<=Y3
RER
Pop Proc
End If
G[1]
Screen Open 2,(X4-X3)+1,(Y4-Y3)+1,Screen Colour,Lowres
Curs Off
Flash Off
Cls 0
Get Palette 1
Zoom 1,X1,Y1,X2,Y2 To 2,0,0,Screen Width-1,Screen Height-1
Get Bob Length(1)+1,0,0 To Screen Width,Screen Height
Screen Close 2
RER
End If
R[485,31,512,42,0]
If AN>0
SC[1]
Cls BC
End If
R[485,5,512,16,0]
If AN>0
SC[1]
SF[1]
Do
G[2]
Repeat
If Inkey$=" "
RER
Pop Proc
End If
MKY
XY
Until MK>0
X1=XX
Y1=YY
Repeat
XY
MKY
Box X1,Y1 To XX,YY
Box X1,Y1 To XX,YY
Until MK=0
G[1]
X2=XX
Y2=YY
For YY=Y1 To Y2
For XX=X1 To X2
C=Point(XX,YY)
If C=FC
Plot XX,YY,BC
End If
Next
Next
Loop
End If
R[485,18,512,29,0]
If AN>0
SC[1]
SF[1]
Do
G[2]
Repeat
If Inkey$=" "
RER
Pop Proc
End If
MKY
XY
Until MK>0
X1=XX
Y1=YY
Repeat
XY
MKY
Box X1,Y1 To XX,YY
Box X1,Y1 To XX,YY
Until MK=0
G[1]
X2=XX
Y2=YY
For YY=Y1 To Y2
For XX=X1 To X2
C=Point(XX,YY)
If C=FC
Plot XX,YY,BC
Goto NXT
End If
If C=BC
Plot XX,YY,FC
End If
NXT:
Next
Next
Loop
End If
R[470,57,482,68,0]
If AN>0
SC[1]
SF[1]
Do
G[2]
Repeat
If Inkey$=" "
RER
Pop Proc
End If
MKY
XY
Until MK>0
X1=XX
Y1=YY
Repeat
XY
MKY
Box X1,Y1 To XX,YY
Box X1,Y1 To XX,YY
Until MK=0
G[1]
X2=XX
Y2=YY
For X=X1 To X2
For Y=Y1 To Y2
C=Point(X,Y)
If(C<>BC) and(C<>FC)
Gosub PLT
End If
Next
Next
Goto ED
PLT:
If Point(X+1,Y)=FC
Plot X+1,Y,BC
End If
If Point(X-1,Y)=FC
Plot X-1,Y,BC
End If
If Point(X,Y+1)=FC
Plot X,Y+1,BC
End If
If Point(X,Y-1)=FC
Plot X,Y-1,BC
End If
Return
ED:
Loop
End If
Loop
End Proc
' Sp /Ic
Procedure Q7
Do
SCLN
CHK[523,604]
If OK=0 or SCI>0
Pop Proc
End If
R[526,5,602,13,0]
If AN>0
If AN=1
F$=Fsel$("","","Load Sprite Bank")
If F$=""
Pop Proc
End If
If Not Exist(F$)
Pop Proc
End If
End If
If AN=2
E["Load Sprite Bank",60]
F$=P$
If F$=""
Pop Proc
End If
If Not Exist(F$)
Pop Proc
End If
End If
If Length(1)>0
E["SURE? (Y/N) Sprites Already In Bank Will Be Lost",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
End If
M[3]
Load F$,1
M[2]
BL
End If
R[526,57,602,65,0]
If AN>0
If AN=1
F$=Fsel$("","","Load Icon Bank")
If F$=""
Pop Proc
End If
If Not Exist(F$)
Pop Proc
End If
End If
If AN=2
E["Load Icon Bank",60]
F$=P$
If F$=""
Pop Proc
End If
If Not Exist(F$)
Pop Proc
End If
End If
If Length(1)>0
E["SURE? (Y/N) Icons Already In Bank Will Be Lost",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
End If
M[3]
Load F$,2
M[2]
BL
End If
R[593,15,602,25,0]
If AN>0 and SPO<Length(1)
Inc SPO
OK7=1
End If
R[593,27,602,37,0]
If AN>0 and SPO>1
Dec SPO
OK7=1
End If
If OK7=1
PSI[0]
OK7=0
End If
R[593,67,602,77,0]
If AN>0 and ICO<Length(2)
Inc ICO
OK8=1
End If
R[593,79,602,89,0]
If AN>0 and ICO>1
Dec ICO
OK8=1
End If
If OK8=1
PSI[1]
OK8=0
End If
R[526,39,602,47,0]
If AN>0 and SPO>0
PT[0]
End If
R[526,91,602,99,0]
If AN>0 and ICO>0
PT[1]
End If
R[532,50,542,54,0]
If AN>0 and Length(1)>0
E["Delete Sprite Bank, SURE (Y/N)?",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
Erase 1
SPO=0
PSI[0]
End If
R[586,50,596,54,0]
If AN>0 and Length(2)>0
E["Delete Icon Bank, SURE (Y/N)?",1]
P$=Upper$(P$)
If P$<>"Y"
Pop Proc
End If
Erase 2
ICO=0
PSI[1]
End If
Loop
End Proc
Procedure PSI[N]
Screen 0
If N=0
B[530,27,586,36,Str$(SPO)-" ",0]
Else
B[530,79,586,88,Str$(ICO)-" ",0]
End If
End Proc
Procedure PT[N]
SC[1]
SF[1]
If N=0
TEMP=Sprite Base(SPO)
WIDTH=Deek(TEMP)*16
HEIGHT=Deek(TEMP+2)
LOP=0
End If
If N=1
TEMP=Icon Base(ICO)
WIDTH=Deek(TEMP)*16
HEIGHT=Deek(TEMP+2)
LOP=1
End If
G[2]
Do
If Inkey$=" "
RER
Pop Proc
End If
MKY
XY
Bar XX,YY To XX+WIDTH,YY+HEIGHT
Wait Vbl
Bar XX,YY To XX+WIDTH,YY+HEIGHT
If MK>0
XY
MKY
If N=0
G[1]
Paste Bob XX,YY,SPO
G[2]
End If
If N=1
G[1]
Paste Icon XX,YY,ICO
G[2]
End If
End If
Loop
End Proc