Post by Admin on Apr 1, 2018 21:29:55 GMT
Requires BBC Basic For Windows and a PC with Microsoft windows
Copy and paste into the BBC Basic editor and run (execute it)
coaches you while you exercise.
Copy and paste into the BBC Basic editor and run (execute it)
coaches you while you exercise.
INSTALL @lib$+"COMLIBA"
ON ERROR PROC_comexit : PRINT 'REPORT$ : END
ON CLOSE PROC_comexit : QUIT
PROC_cominit
Pitch% = 0
Speed% = 0
Voice$ = ""
an%=0:k=0
d%=0:d%=1:ti%=0
reply$="":tic%=0 :reply%=0
REM if you are reading this, you are seeing an experiment in progress.. unknown effects
REM the following command loads libraries I want to include in this library.
PROCgr("graphics cls move 500 500 print Turn your volume up for the instructors voice")
PROCgr("say in minutes")
PROCgr("say how long would you like to exercise for ")
PROCgr("move 10 550 print How many minutes do you want to exercise for ")
REPEAT reply$=FNinput(10,500,10)
UNTIL VAL(reply$)>0
reply%=VAL(reply$)
PROCgr("say you have selected "+STR$(reply%)+" minutes ")
PROCgr("move 10 550 print you chose "+STR$(reply%)+" minutes ")
PROCgr("say begin exercising in "):PROCgr("say ten "):PROCgr("say nine "):PROCgr("say eight "):PROCgr("say seven "):PROCgr("say six "):PROCgr("say five ")
PROCgr("say four :"):PROCgr("say three "):PROCgr("say two "):PROCgr("say one "):PROCgr("say begin ")
FOR tic%=1 TO reply%
REPEAT WAIT 100 : ti%+=1 : PROCgr("move 10 550 print "+STR$(tic%-1)+" minutes "+STR$(ti%)+" seconds has passed so far "):UNTIL ti%=59
ti%=0
PROCgr("say "+STR$(tic%)+" minutes ")
PROCgr("move 10 550 print "+STR$(tic%)+" minutes has passed so far ")
NEXT tic%
PROCgr("say your time is up and you can relax ")
PROCgr("move 10 550 print your time is up and you can relax ")
PROC_comexit
END
PROCcloseall
END
DEF PROCspeak(phrase$,pitch%,speed%,voice$)
tts% = FN_createobject("Sapi.SpVoice")
IF tts% THEN
LOCAL qual$
qual$ = "<PITCH ABSMIDDLE="""""+STR$pitch%+"""""/><RATE ABSSPEED="""""+STR$speed%+"""""/>"
IF voice$<>"" qual$ += "<VOICE REQUIRED=""""NAME="+voice$+"""""/>"
PROC_callmethod(tts%, "Speak("""+qual$+phrase$+""")")
PROC_releaseobject(tts%)
ENDPROC
ENDIF
tts% = FN_createobject("Speech.VoiceText")
IF tts% THEN
PROC_callmethod(tts%, "Register("""",""COMLIB demo"")")
PROC_putvalue(tts%, "Enabled(BTRUE)")
PROC_putvalue(tts%, "Speed("+STR$INT(150*3^(speed%/10))+")")
PROC_callmethod(tts%, "Speak("""+phrase$+""", 1)")
REPEAT
SYS "Sleep", 150
UNTIL FN_getvalueint(tts%, "IsSpeaking") = 0
PROC_releaseobject(tts%)
ENDPROC
ENDIF
ENDPROC
REM the following code is RETROLIB.. created by Michael J Gallup
REM the world is free to use it ( including myself ) to help become more productive.
DEFPROCturtle(coun%,angle,pen$,RETURN x%,RETURN y%)
PRIVATE sx%,sy%
LOCAL skip$
IF pen$="move" THEN sx%=x%:sy%=y%
IF pen$="up" OR pen$="down" THEN
sx%+=coun%*COS(RAD(angle))
sy%+=coun%*SIN(RAD(angle))
IF pen$="down" THEN LINE x%,y%,sx%,sy%
ENDIF
x%=sx%:y%=sy%
ENDPROC
DEFPROCgr(cmd$)
PRIVATE pen$,x%,y%,angle
LOCAL x$,y$,h$,v$,c$,word$,size$,size2$,lx%,ly%,build$,wd$,r$,g$,b$,rr%,gg%,bb%,di%,di$,amt$,name$,h%,v%,resp$,speed$,speed,amt%,coun%
REPEAT
word$ = FNword(cmd$)
IF word$="color" THEN
c$=FNword(cmd$)
PROCcolor("f",c$)
ENDIF
IF word$="r" THEN angle=angle - VAL(FNword(cmd$))
IF word$="l" THEN angle=angle + VAL(FNword(cmd$))
IF word$="f" THEN PROCturtle(VAL(FNword(cmd$)),angle,pen$,x%,y%)
IF word$="rect" THEN
x$=FNword(cmd$):y$=FNword(cmd$):h$=FNword(cmd$):v$=FNword(cmd$)
PROCrect(VAL(x$),VAL(y$),VAL(h$),VAL(v$))
ENDIF
IF word$="graphics" THEN
PROCgraphics(1000,600)
ENDIF
IF word$="mask" THEN
x$=FNword(cmd$):x%=VAL(x$):y$=FNword(cmd$):y%=VAL(y$):h$=FNword(cmd$):h%=VAL(h$):v$=FNword(cmd$):v%=VAL(v$)
PROCmask(x%,y%,h%,v%)
ENDIF
IF word$="size" THEN size$=FNword(cmd$):PROCdotsize(VAL(size$))
IF word$="move" THEN
x$=FNword(cmd$):y$=FNword(cmd$)
lx%= VAL(x$)
ly%= VAL(y$)
x%=lx%:y%=ly%
PROCturtle(0,angle,"move",x%,y%)
PROCgo("move",0)
ENDIF
IF word$="ellipse" THEN
x$=FNword(cmd$):y$=FNword(cmd$):size$=FNword(cmd$):size2$=FNword(cmd$):di$=FNword(cmd$)
PROCellipse(VAL(x$),VAL(y$),VAL(size$),VAL(size2$),r%,g%,b%,VAL(di$))
ENDIF
IF word$="print" THEN
REPEAT
wd$= FNword(cmd$)
IF wd$<>":" THEN build$+=" "+wd$
UNTIL wd$="" OR MID$(wd$,LEN(wd$),1)=":"
PROCpr(lx%,ly%,build$,"15")
ENDIF
IF word$="say" THEN
REPEAT
wd$= FNword(cmd$)
IF wd$<>":" OR wd$<>"." OR wd$<>"?" THEN build$+=" "+wd$
UNTIL wd$="" OR INSTR(":.?",RIGHT$(wd$))>0
PROCspeak(build$,Pitch%,Speed%,Voice$)
ENDIF
IF word$="rgb" THEN
r$=FNword(cmd$):g$=FNword(cmd$):b$=FNword(cmd$)
r%=VAL(r$):g%=VAL(g$):b%=VAL(b$)
PROCcrgb(r%,g%,b%)
ENDIF
IF word$="block" THEN
x$=FNword(cmd$):y$=FNword(cmd$):size$=FNword(cmd$):di$=FNword(cmd$)
PROC_block(VAL(x$),VAL(y$),VAL(size$),r%,g%,b%,VAL(di$))
ENDIF
REM button x y di
IF word$="button" THEN
x$=FNword(cmd$):y$=FNword(cmd$):di$=FNword(cmd$)
x%=VAL(x$):y%=VAL(y$):di%=VAL(di$)
PROC_button(x%,y%,15,25,r%,g%,b%,di%)
ENDIF
IF word$="sbox" THEN
x$=FNword(cmd$):y$=FNword(cmd$):h$=FNword(cmd$):v$=FNword(cmd$):
c$=FNword(cmd$)
PROCsbox(VAL(x$),VAL(y$),VAL(h$),VAL(v$),c$)
ENDIF
IF word$="sphere" THEN
x$=FNword(cmd$):y$=FNword(cmd$):size$=FNword(cmd$):di$=FNword(cmd$)
PROC_sphere(VAL(x$),VAL(y$),VAL(size$),r%,g%,b%,VAL(di$))
ENDIF
IF word$="savebmp" THEN
name$=FNword(cmd$)+".bmp":x$=FNword(cmd$):x%=VAL(x$):y$=FNword(cmd$):y%=VAL(y$):h$=FNword(cmd$):h%=VAL(h$):v$=FNword(cmd$):v%=VAL(v$)
OSCLI "SCREENSAVE """+name$+""" "+STR$(x%)+","+STR$(y%)+","+STR$(h%)+","+STR$(v%)
ENDIF
IF word$="loadbmp" THEN
name$=FNword(cmd$)+".bmp":x$=FNword(cmd$):x%=VAL(x$):y$=FNword(cmd$):y%=VAL(y$):h$=FNword(cmd$):h%=VAL(h$):v$=FNword(cmd$):v%=VAL(v$)
OSCLI "DISPLAY """+name$+""" "+STR$(x%)+","+STR$(y%)+","+STR$(h%)+","+STR$(v%)
ENDIF
IF word$="lefteye" THEN
x$=FNword(cmd$):y$=FNword(cmd$):location$=FNword(cmd$):speed$=FNword(cmd$):speed=VAL(speed$)
FOR x=1 TO 40:PROClefteye(VAL(x$),VAL(y$),location$,speed):PROCrighteye(VAL(x$)-100,VAL(y$),location$,speed):NEXT x
ENDIF
IF word$="c" OR word$="n" OR word$="s" OR word$="e" OR word$="w" OR word$="ne" OR word$="nw" OR word$="se" OR word$="sw" OR word$="fill" THEN
resp$=word$
amt$=FNword(cmd$)
amt%=VAL(amt$)
PROCgo(resp$,amt%)
ENDIF
IF word$="up" OR word$="down" THEN pen$=word$:PROCgo(word$,0)
IF word$="cls" THEN CLG
UNTIL word$ = ""
ENDPROC
REM thanks Richard
DEF FNword(RETURN A$)
PRIVATE Alphabet$
LOCAL space$
Alphabet$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"+"0123456789:,./"
space$ = FNtoken(A$, " ")
= FNtoken(A$,Alphabet$)
DEF FNtoken(RETURN A$, list$)
LOCAL T$
WHILE INSTR(list$, LEFT$(A$,1))
T$ += LEFT$(A$,1)
A$ = MID$(A$,2)
ENDWHILE
= T$
DEFPROCcrgb(r%,g%,b%)
COLOUR 0,r%,g%,b% : GCOL 0
ENDPROC
REM RETROLIB 2
REM THIS IS "RETROLIB" library version for NOVEMBER 28 2016 @ 6:08am
DEF PROCblast(x%,y%,chance%)
LOCAL dv%,dh%,xc%
PROCdotsize(1)
REPEAT
dv%=RND(chance%)
dh%=RND(chance%)
PROCdotsize(2)
PROCdotrgb(x%+dh%,y%+dv%,255,RND(255),100)
dv%=RND(chance%)
dh%=RND(chance%)
PROCdotrgb(x%-dh%,y%+dv%,255,RND(255),100)
dv%=RND(chance%)
dh%=RND(chance%)
PROCdotrgb(x%+dh%,y%-dv%,255,RND(255),100)
dv%=RND(chance%)
dh%=RND(chance%)
PROCdotrgb(x%-dh%,y%-dv%,255,RND(255),100)
WAIT 1
xc%+=1
UNTIL xc%>20
ENDPROC
DEF PROC_button(H,V,BEGIN,SIZE,X,C,A,DI)
PROCcolor("f","000,000,000")
LOCAL R,G,B,P
R=X
G=C
B=A
P=SIZE-BEGIN
P=P/2
P=BEGIN+P
FOR Y=P TO SIZE
COLOUR 0,X,C,A :GCOL 0
LINE H-Y,V-Y,H+Y,V-Y
LINE H+Y,V-Y,H+Y,V+Y
LINE H+Y,V+Y,H-Y,V+Y
LINE H-Y,V+Y,H-Y,V-Y
X=X-DI
C=C-DI
A=A-DI
IF X<2 THEN X=2
IF C<2 THEN C=2
IF A<2 THEN A=2
NEXT Y
P=SIZE-BEGIN
P=P/2
P=BEGIN+P
FOR Y=BEGIN TO P
COLOUR 1,X,C,A :GCOL 1
LINE H-Y,V-Y,H+Y,V-Y
LINE H+Y,V-Y,H+Y,V+Y
LINE H+Y,V+Y,H-Y,V+Y
LINE H-Y,V+Y,H-Y,V-Y
X=X+DI
C=C+DI
A=A+DI
NEXT Y
PROCpaint(H,V,FNnumstr(R)+" "+FNnumstr(G)+" "+FNnumstr(B))
PROCresetrgb
ENDPROC
DEF PROC_block(H,V,SIZE,X,C,A,DI)
LOCAL P,Y
P=SIZE/2
FOR Y=1 TO SIZE
COLOUR 0,X,C,A:GCOL 0
LINE H-Y,V-Y,H+Y,V-Y
LINE H+Y,V-Y,H+Y,V+Y
LINE H+Y,V+Y,H-Y,V+Y
LINE H-Y,V+Y,H-Y,V-Y
X=X-DI
C=C-DI
IF X<2 THEN X=2
IF C<2 THEN C=2
IF A<2 THEN A=2
P=P-1
NEXT Y
ENDPROC
DEF PROC_donut(H,V,RR,GG,BB)
PROC_ellipsering(3,3,H,V,30,40,RR,GG,BB,10)
PROC_sphere(H,V,10,RR,GG,BB,7)
ENDPROC
DEF PROC_ellipsering(CENTERH,CENTERV,H,V,SIZE,THICKNESS,X,C,A,DI)
IF SIZE > THICKNESS THEN SIZE = THICKNESS
OC=THICKNESS/2
OUTCENTERH=CENTERH+OC
OUTCENTERV=CENTERV+OC
R=0
SWITCH=0
DEPTHCOUNT=SIZE/2
FOR Y=1 TO DEPTHCOUNT
COLOUR 1,X,C,A GCOL 1
ELLIPSE H,V,OUTCENTERH-R,OUTCENTERV-R
ELLIPSE H,V,OUTCENTERH+R,OUTCENTERV+R
R=R+1
(leap)
X=X-DI
C=C-DI
A=A-DI
IF X<2 THEN X=2
IF C<2 THEN C=2
IF A<2 THEN A=2
NEXT Y
PROCresetrgb
ENDPROC
REM ellipse h,v,sizex,sizey,R,G,B,dimmer
DEF PROCellipse(h,v,sizex,sizey,x,c,a,dimmer):REM' dimmer cannot be more than 24
LOCAL limit,y,hi,wi
MOVE h,v
IF sizex>sizey THEN limit=sizex
IF sizey>sizex THEN limit=sizey
FOR y=0 TO limit
PROCcrgb(x,c,a)
hi=hi+1:IF sizex>sizey THEN hi=hi+1
wi=wi+1:IF sizey>sizex THEN wi=wi+1
IF hi>sizex THEN hi=sizex
IF wi>sizey THEN wi=sizey
ELLIPSE h,v,hi,wi
x=x-dimmer
c=c-dimmer
a=a-dimmer
IF x<2 THEN x=2
IF c<2 THEN c=2
IF a<2 THEN a=2
NEXT y
ENDPROC
DEFPROC_sphere(H,V,SIZE,R,G,B,DI)
LOCAL r%,g%,b%,di%,c%,x%,size%,skip%
skip%=FALSE
r%=R
g%=G
b%=B
size%=SIZE
di%=DI
FOR x%=0 TO size%
c%=50
r%=r%-di%
g%=g%-di%
b%=b%-di%
IF r% <2 THEN r%=2
IF g% <2 THEN g%=2
IF b%<2 THEN b%=2
IF r%<50 AND g%<50 AND b%<50 THEN skip%=TRUE
IF skip%=FALSE THEN
COLOUR 1,r%,g%,b%:GCOL 1
CIRCLE H,V,x%
ENDIF
NEXT x%
PROCresetrgb
ENDPROC
DEFPROCdotsize(n)
VDU 23,23,n|
ENDPROC
REM "mygraphics" - "INTERFACE" - "OBJECTS" - (Combined libraries) * to make it easier to manage
REM save as "RETROLIB"
REM To make this easier to modify, keep the remarks
REM "OBJECTS" library
DEFPROCrighteye(x,y,location$,speed)
PRIVATE dx,dy,counx,couny,eyeh,eyev,seyeh,seyev
IF counx<x-20 THEN counx=x-20:REM this ensures the pupil stays within eye
IF counx>x+20 THEN counx=x+20
IF couny<y-20 THEN couny=y-20
IF couny>y+20 THEN couny=y+20
CASE location$ OF
WHEN "center":dx=x:dy=y:eyeh=15:eyev=15
WHEN "right":dx=x+80:dy=y:eyeh=10:eyev=15
WHEN "down":dx=x:dy=y-80:eyev=10:eyeh=15
WHEN "up":dx=x:dy=y+80:eyev=10:eyeh=15
WHEN "left":dx=x-80:dy=y:eyeh=10:eyev=15
ENDCASE
IF counx<dx THEN counx=counx+1
IF counx>dx THEN counx=counx-1
IF couny<dy THEN couny=couny+1
IF couny>dy THEN couny=couny-1
IF seyeh<eyeh THEN seyeh+=.4
IF seyeh>eyeh THEN seyeh-=.4
IF seyev<eyev THEN seyev+=.4
IF seyev>eyev THEN seyev-=.4
REM dx, dy is meant to hold the destination of the pupil
REM counx,couny is meant to hold the current pupil location
REM eyeh,eyev is meant to hold the shape of the pupil as it moves
REM speed is the rate that the pupil moves. I am not sure how fast it should move but it will be in decimal value
GCOL 15
CIRCLE FILL x,y,30
GCOL 4
ELLIPSE FILL counx,couny,seyeh,seyev
PROCcolor("f","000,000,000")
ELLIPSE FILL counx,couny,seyeh/2,seyev/2
WAIT speed
ENDPROC
DEFPROClefteye(x,y,location$,speed)
PRIVATE dx,dy,counx,couny,eyeh,eyev,seyeh,seyev
IF counx<x-20 THEN counx=x-20:REM this ensures the pupil stays within eye
IF counx>x+20 THEN counx=x+20
IF couny<y-20 THEN couny=y-20
IF couny>y+20 THEN couny=y+20
CASE location$ OF
WHEN "center":dx=x:dy=y:eyeh=15:eyev=15
WHEN "right":dx=x+80:dy=y:eyeh=10:eyev=15
WHEN "down":dx=x:dy=y-80:eyev=10:eyeh=15
WHEN "up":dx=x:dy=y+80:eyev=10:eyeh=15
WHEN "left":dx=x-80:dy=y:eyeh=10:eyev=15
ENDCASE
IF counx<dx THEN counx=counx+1
IF counx>dx THEN counx=counx-1
IF couny<dy THEN couny=couny+1
IF couny>dy THEN couny=couny-1
IF seyeh<eyeh THEN seyeh+=.4
IF seyeh>eyeh THEN seyeh-=.4
IF seyev<eyev THEN seyev+=.4
IF seyev>eyev THEN seyev-=.4
REM dx, dy is meant to hold the destination of the pupil
REM counx,couny is meant to hold the current pupil location
REM eyeh,eyev is meant to hold the shape of the pupil as it moves
REM speed is the rate that the pupil moves. I am not sure how fast it should move but it will be in decimal value
GCOL 15
CIRCLE FILL x,y,30
GCOL 4
ELLIPSE FILL counx,couny,seyeh,seyev
PROCcolor("f","000,000,000")
ELLIPSE FILL counx,couny,seyeh/2,seyev/2
WAIT speed
ENDPROC
REM COLORMIX object mixer
DEFFNcolormix(x,y)
PRIVATE rgb$,r%,g%,b%,switch%
LOCAL h%,v%,click%
MOUSE h%,v%,click%
IF click%=4 THEN
IF h%>x AND h%<x+50 AND v%>y AND v%<y+255 THEN r%=v%-y
IF h%>x+49 AND h%<x+90 AND v%>y AND v%<y+255 THEN g%=v%-y
IF h%>x+99 AND h%<x+140 AND v%>y AND v%<y+255 THEN b%=v%-y
ENDIF
IF switch%=0 OR click%=4 THEN
PROCsbox(x-5,y-5,x+150,y+265,"255,255,255")
PROCsbox(x,y+r%,x+40,y+r%+10,"200,000,000")
PROCsbox(x+50,y+g%,x+90,y+g%+10,"000,200,000")
PROCsbox(x+100,y+b%,x+140,y+b%+10,"000,000,200")
switch%=1
rgb$=FNnumstr(r%)+","+FNnumstr(g%)+","+FNnumstr(b%)
PROCsbox(x-5,y+265,x+150,y+295,rgb$)
ENDIF
=rgb$
REM GRAPHICS(x,y)
DEF PROCgraphics(x,y)
VDU 23,22,x;y;8,15,16,1
OFF
VDU 5
REM these variables are temporary
N%=0
N%=20
DIM X(20),Y(20),H(20),V(20)
ENDPROC
DEFFNkey
response$=INKEY$(0)
=response$
REM SBOX **********************
DEF PROCsbox(x%,y%,w%,h%,c$)
LOCAL ry%,sx%,sy%
sx%=x%:sy%=y%
IF x%>w% THEN x%=w%:w%=sx%
IF y%>h% THEN y%=h%:h%=sy%
ry%=y%
PROCcolor("f",c$)
REPEAT
LINE x%,y%,w%,y%
y%=y%+1
UNTIL y%=h%
y%=ry%
IF c$<>"0" THEN PROCcolor("f","000,000,000") ELSE PROCcolor("f","white")
LINE x%+2,y%+2,w%-2,y%+2
LINE w%-2,y%+2,w%-2,h%-4
LINE w%-2,h%-4,x%+2,h%-4
LINE x%+2,h%-4,x%+2,y%+2
PROCresetrgb
ENDPROC
REM RECT **********************
DEFPROCrect(x%,y%,w%,h%)
LOCAL sx%,sy%
sx%=x%:sy%=y%
IF x%>w% THEN x%=w%:w%=sx%
IF y%>h% THEN y%=h%:h%=sy%
LINE x%,y%,w%,y%
LINE w%,y%,w%,h%
LINE w%,h%,x%,h%
LINE x%,h%,x%,y%
ENDPROC
REM pixel *******************
DEFPROCpixel(x%,y%,c$)
PROCcolor("f",c$)
MOVE x%,y%:DRAW x%,y%
ENDPROC
REM SET c$ can be colors like blue or 1 or a R,G,B color
DEF PROCset(x%,y%,c$)
LOCAL h%
PROCcolor("f",c$)
FOR h%=0 TO 20
LINE x%+h%,y%,x%+h%,y%+20
NEXT
MOVE 0,0
ENDPROC
REM restore default color palettes
DEFPROCresetrgb
COLOUR 0,0,0,0 :COLOUR 1,200,0,0 :COLOUR 2,000,200,000
COLOUR 3,200,200,000:COLOUR 4,000,000,200:COLOUR 5,200,000,200
COLOUR 6,000,200,200:COLOUR 7,200,200,200:COLOUR 8,056,056,056
COLOUR 9,248,056,056:COLOUR 10,056,248,056:COLOUR 11,248,248,056
COLOUR 12,056,056,248:COLOUR 13,248,056,248:COLOUR 14,056,248,248
COLOUR 15,248,248,248
ENDPROC
DEF PROCcolor(fb$,rgb$)
PRIVATE assemble$,br%,bg%,bb%
IF rgb$="0" OR rgb$="black" THEN rgb$="000,000,000"
IF rgb$="1" OR rgb$="red" THEN rgb$="200,000,000"
IF rgb$="2" OR rgb$="green" THEN rgb$="000,200,000"
IF rgb$="3" OR rgb$="yellow" THEN rgb$="200,200,000"
IF rgb$="4" OR rgb$="blue" THEN rgb$="000,000,200"
IF rgb$="5" OR rgb$="magenta" THEN rgb$="200,000,200"
IF rgb$="6" OR rgb$="cyan" THEN rgb$="000,200,200"
IF rgb$="7" OR rgb$="white" THEN rgb$="200,200,200"
IF rgb$="8" OR rgb$="grey" THEN rgb$="056,056,056"
IF rgb$="9" OR rgb$="light red" THEN rgb$="248,056,056"
IF rgb$="10" OR rgb$="light green" THEN rgb$="056,248,056"
IF rgb$="11" OR rgb$="light yellow" THEN rgb$="248,248,056"
IF rgb$="12" OR rgb$="light blue" THEN rgb$="056,056,248"
IF rgb$="13" OR rgb$="light magenta" THEN rgb$="248,056,248"
IF rgb$="14" OR rgb$="light cyan" THEN rgb$="056,248,248"
IF rgb$="15" OR rgb$="light white" THEN rgb$="248,248,248"
assemble$=rgb$
br%=VAL(MID$(assemble$,1,3)):bg%=VAL(MID$(assemble$,5,3)):bb%=VAL(MID$(assemble$,9,3))
IF fb$="f" OR fb$="F" THEN COLOUR 0,br%,bg%,bb% : GCOL 0
IF fb$="b" OR fb$="B" THEN COLOUR 1,br%,bg%,bb% : GCOL 128+1
ENDPROC
REM h and v must always be a higher value as they are the top right corner of the image.( I make make this smart like sbox)
DEFPROCmask(x%,y%,h%,v%)
LOCAL dx%,dy%,c%,counx%,couny%
counx%=0:couny%=0
dx%= h%-x%
dy%= v%-y%
IF dx%>dy% THEN
REPEAT
c%=TINT(x%+counx%,y%+couny%)
IF c%=0 THEN PROCpixel(x%+counx%,y%+couny%+dy%+1,"light white") ELSE PROCpixel(x%+counx%,y%+couny%+dy%+1,"0")
couny%+=1:IF couny%=y%+dy% THEN couny%=0:counx%=counx%+1
UNTIL counx%=dx%
ENDIF
IF dy%>dx% THEN
REPEAT
c%=TINT(x%+counx%,y%+couny%)
IF c%=0 THEN PROCpixel(x%+counx%,y%+couny%+dy%+1,"255,255,255") ELSE PROCpixel(x%+counx%,y%+couny%+dy%+1,"0")
counx%+=1:IF counx%=x%+dx% THEN counx%=0:couny%=couny%+1
UNTIL couny%=dy%
ENDIF
ENDPROC
DEFPROCgo(cm$,coun%)
PRIVATE x%,y%,pen%,c$
LOCAL c%
IF cm$="up" THEN pen%=1
IF cm$="down" THEN pen%=0
IF cm$="fill" THEN PROCpaint(x%,y%,STR$(coun%))
IF cm$="c" THEN PROCcolor("f",STR$(coun%))
IF cm$="n" THEN
REPEAT
y%=y%+1:IF pen%=0 THEN PROCpixel(x%,y%,STR$(coun%))
c%+=1
UNTIL c%=coun%
ENDIF
IF cm$="s" THEN
REPEAT
y%=y%-1:IF pen%=0 THEN PROCpixel(x%,y%,STR$(coun%))
c%+=1
UNTIL c%=coun%
ENDIF
IF cm$="e" THEN
REPEAT
x%+=1:IF pen%=0 THEN PROCpixel(x%,y%,STR$(coun%))
c%+=1
UNTIL c%=coun%
ENDIF
IF cm$="w" THEN
REPEAT
x%-=1:IF pen%=0 THEN PROCpixel(x%,y%,STR$(coun%))
c%+=1
UNTIL c%=coun%
ENDIF
IF cm$="ne" THEN
REPEAT
x%+=1:y%+=1:IF pen%=0 THEN PROCpixel(x%,y%,STR$(coun%))
c%+=1
UNTIL c%=coun%
ENDIF
IF cm$="nw" THEN
REPEAT
x%-=1:y%+=1:IF pen%=0 THEN PROCpixel(x%,y%,STR$(coun%))
c%+=1
UNTIL c%=coun%
ENDIF
IF cm$="sw" THEN
REPEAT
x%-=1:y%-=1:IF pen%=0 THEN PROCpixel(x%,y%,STR$(coun%))
c%+=1
UNTIL c%=coun%
ENDIF
IF cm$="se" THEN
REPEAT
x%+=1:y%-=1:IF pen%=0 THEN PROCpixel(x%,y%,STR$(coun%))
c%+=1
UNTIL c%=coun%
ENDIF
ENDPROC
DEFFNnumstr(num)
LOCAL cov$,l%
cov$=STR$(num)
l%=LEN(cov$)
IF l%=1 THEN ret$="00"+cov$
IF l%=2 THEN ret$="0"+cov$
IF l%=3 THEN ret$=cov$
=ret$
DEFPROCpaint(x%,y%,co$)
PROCcolor("b",FNrgb(x%,y%)):PROCcolor("f",co$)
FILL x%,y%
ENDPROC
REM dotrgb ********************************
DEFPROCdotrgb(x%,y%,r%,g%,b%)
COLOUR 0,r%,g%,b% : GCOL 0
MOVE x%,y%:DRAW x%,y%
ENDPROC
REM *****SPECIAL RGB tools (color extraction) has use with PROCdotrgb
DEF PROCrgbret(x%,y%,RETURN r%,RETURN g%,RETURN b%)
LOCAL rgb%
rgb%=TINT(x%,y%)
b%=INT(rgb%/(256*256))
g%=INT((rgb%-b% *256*256)/256)
r%=INT(rgb%-b%*256*256-g%*256)
ENDPROC
REM experimental
DEFFNrgb(x%,y%)
LOCAL r$,g$,b$,join$,r,g,b
rgb%=TINT(x%,y%)
b=INT(rgb%/(256*256))
g=INT((rgb%-b *256*256)/256)
r=INT(rgb%-b*256*256-g*256)
r$=FNnumstr(r):g$=FNnumstr(g):b$=FNnumstr(b)
join$=r$+","+g$+","+b$
=join$
REM getpic sorta functions like GET from the 80s but in this case it just assigns capture area information
REM each getpic only needs to be called once, but you can reassign
REM num refers to the variable arrays that will carry each image's capture point (it ranges from 0- 20)
REM I guess h,v are the height and width of the image.
DEFPROCgetpic(num%,xx,yy,hh,vv)
N%=num%
X(N%)=xx
Y(N%)=yy
H(N%)=hh
V(N%)=vv
ENDPROC
REM Hmmm
REM now that the image coordinates are stored, we can move it and redefine the borders
DEFPROCpastepic(num%,nx,ny)
LOCAL tx%,ty%,th%,tv%
N%=num%
tx%=X(N%)
ty%=Y(N%)
th%=H(N%)
tv%=V(N%)
RECTANGLE tx%,ty%,th%,tv% TO nx,ny
X(N%)=nx
Y(N%)=ny
ENDPROC
REM seems to work the same?
DEFPROCmovepic(num,nx,ny)
LOCAL tx%,ty%
tx%=X(N%)
ty%=Y(N%)
RECTANGLE SWAP tx%,ty%,H(num),V(num) TO nx,ny
X(N%)=nx
Y(N%)=ny
ENDPROC
REM "INTERFACE" -library - for graphics text input and other tools
REM X,Y,message,r,g,b
DEF PROCpr(X,Y,msg$,c$)
PRIVATE trackx,tracky,trackmsg$,trackc$
LOCAL initialx%,fi%,reduction%,tx,ty
IF trackx=X AND tracky=Y AND trackmsg$<>msg$ THEN PROCprsub(trackx,tracky,trackmsg$,"000,000,000")
IF trackx<>X OR tracky<>Y OR trackmsg$<>msg$ OR trackc$<>c$ THEN
initialx%=LEN(msg$)
PROCcolor("f",c$)
GCOL 0
LET tx= X+initialx%+25
LET ty= Y:reduction%=0
reduction%=initialx%/2
reduction%=reduction%*6
IF initialx%<20 THEN reduction%=reduction%/2
initialx%=initialx%*22-reduction%
FOR fi%=12 TO 48
LINE X-3,Y+20-fi%,X+initialx%+8,Y+20-fi%
NEXT
COLOUR 0,0,0,0
GCOL 0
MOVE tx,ty
PRINT msg$
MOVE 0,0
ENDIF
trackx=X:tracky=Y:trackmsg$=msg$:trackc$=c$
ENDPROC
DEFPROCprsub(X,Y,msg$,c$)
LOCAL initialx%,fi%,reduction%,tx,ty
initialx%=LEN(msg$)
PROCcolor("f",c$)
GCOL 0
LET tx= X+initialx%+25
LET ty= Y:reduction%=0
reduction%=initialx%/2
reduction%=reduction%*6
IF initialx%<20 THEN reduction%=reduction%/2
initialx%=initialx%*22-reduction%
FOR fi%=12 TO 48
LINE X-3,Y+20-fi%,X+initialx%+8,Y+20-fi%
NEXT
COLOUR 0,0,0,0
GCOL 0
MOVE tx,ty
PRINT msg$
MOVE 0,0
ENDIF
ENDPROC
REM H,V,TEXTLIMIT (simpler?)
DEF FNinput(bx,by,textlimit)
LOCAL fill,MESSAGE$,remains%,cursor%
gbx%=bx:gby%=by:initialx%=0:sl%=0:key$="":MESSAGE$="":MES$=""
initialx%=textlimit*16.2
FOR fill=1 TO 58
PROCcolor("f","15"):LINE bx+3,by+20-fill,bx+initialx%,by+20-fill
NEXT fill
PROCcolor("f","0"):LINE bx+3,by+20,bx+initialx%,by+20:LINE bx+3,by+20-fill,bx+initialx%,by+20-fill:
REPEAT
REPEAT
key$ =INKEY$(1)
PROCcolor("F","0")
MOVE bx,by:PRINT MESSAGE$;"_" :* REFRESH
sl%=LEN(MESSAGE$)
remains%=sl%-cursor%
lstring$=LEFT$(MESSAGE$,cursor%):rstring$=RIGHT$(MESSAGE$,remains%)
UNTIL key$ <>""
sl%=LEN(MESSAGE$)
IF INKEY(-48) sl%=LEN(MESSAGE$)-1:key$=""
REPEAT UNTIL INKEY(0)=-1
IF sl%<LEN(MESSAGE$) THEN
PROCcolor("F","15")
MOVE bx,by
PRINT MESSAGE$;"_"
ENDIF
MES$=MID$(MESSAGE$,0,sl%)
MESSAGE$=MES$
PROCcolor("F","15"):MOVE bx,by:PRINT MESSAGE$;"_"
IF LEN(key$) = 1 THEN
IF LEN(MESSAGE$)<textlimit THEN PROCcolor("F","15"):MOVE bx,by:PRINT MESSAGE$;"_": MESSAGE$=MESSAGE$+key$:* REFRESH OFF
REM (jump)
ENDIF
UNTIL INKEY(-74)
* REFRESH ON
=MESSAGE$
DEFFNbuttonz(X,Y,msg$)
LOCAL initialx%,fi%,reduction%,tx,ty,mx%,my%,mb%,ad%,ady%,c$
PRIVATE st$
initialx%=LEN(msg$)
LET tx= X+initialx%+25
LET ty= Y:reduction%=0
reduction%=initialx%/2
reduction%=reduction%*6
IF initialx%<20 THEN reduction%=reduction%/2
initialx%=initialx%*22-reduction%
MOUSE mx%,my%,mb%
ad%=initialx%+8:ad%+=X:ady%=Y-28
IF mx% >X AND mx%<ad% AND my%<Y+8 AND my%>ady% THEN
c$="255,255,255"
IF mb%=4 THEN st$=msg$
ELSE c$="200,200,200"
ENDIF
IF FNrgb(X,Y)="000,000,000" THEN c$="200,200,200"
PROCcolor("f",c$)
IF FNrgb(X,Y)<>c$ THEN
FOR fi%=12 TO 48
LINE X-3,Y+20-fi%,X+initialx%+8,Y+20-fi%
NEXT
PROCcolor("f","000,000,000")
MOVE tx,ty
PRINT msg$
ENDIF
MOVE 0,0 REM hide that thing
=st$