Post by Admin on Mar 8, 2020 19:36:44 GMT
The program is being worked on so I guess I should just leave it as it was for history records.
The next version will be RETROLIB 12, as RETROLIB 11 is already made and is for a texture shading project that isn't completed.
The next version will be RETROLIB 12, as RETROLIB 11 is already made and is for a texture shading project that isn't completed.
REM RETROLIB 10 with a few demos.. FNtype(x,y) added March 2018
INSTALL @lib$+"COMLIBA"
ON ERROR PROC_comexit : PRINT 'REPORT$ : END
ON CLOSE PROC_comexit : QUIT
PROC_cominit
dmy$="" :REM a dummy string
Pitch% = 0
Speed% = 0
Voice$ = ""
m$=""
an%=0
d%=0:d%=1:ti%=0
reply$="":tic%=0 :reply%=0
REM inserted program here to test buttonz tool
PROCgraphics(1000,600)
ON ERROR END
PROCgr("move 10 800 print press the A key to test the gaming key tool")
dmy$=FNabutton(10,700,50,"green","fill")
PROCcolor("f","cyan"):PROCarrowu(40,680)
REPEAT
IF FNgkey ="A" THEN PROCgr("move 500 500 print A") :REM experimental game keysl
IF FNabutton(10,700,50,"green","yip")="yip" THEN PROCcolor("f","yellow"):MOVE 100,700:PRINT "You touched the green button FNabutton is cool"
a$= FNbuttonz(0,0,"clearitall")
a$= FNbuttonz(300,300,"Limitless buttons and no need for complexity !!")
a$= FNbuttonz(100,100,"This is a RETROLIB 6 button TEST for DECEMBER 25 2016")
a$= FNbuttonz(100,50,"Lets skip this and look at the next options")
PROCcolor("f","cyan"):PROCarrowd(130,140)
IF a$="This is a RETROLIB 6 button TEST for DECEMBER 25 2016" THEN GCOL RND(15)-1: RECTANGLE FILL RND(800),RND(600),RND(800),RND(600)
IF a$="Limitless buttons and no need for complexity !!" THEN GCOL RND(15)-1: CIRCLE FILL RND(800), RND(600), RND(200)
WAIT 10
UNTIL a$="Lets skip this and look at the next options"
REM this is a diffrent main program...********************
PROCbcolor("0") :REM set background color to black NEW !! TRUE CORE COLOR
PROCgr("cls")
REPEAT
m$=""
m$=FNbuttonz(0,0,"clearitall"):REM clears any button presses from previous sweep (must be at begining of button checks)
m$=FNbuttonz(10,500,"Exercise")
m$=FNbuttonz(500,500,"Graphics Demo")
m$=FNbuttonz(10,700,"Christmas Tree")
WAIT 0
UNTIL m$<>""
IF m$="Christmas Tree" THEN
PROCcolor("b","000,000,000"):REM set background color to black OLD **not core color -- its a palette
PROCgr("loadbmp tree 10 0 900 900")
PROCgr("say merry christmas")
REPEAT
REM You must define rgb before you use a shape like sphere or you will get an unknown variable error
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 800 100 25 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 650 100 25 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 500 70 25 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 300 120 25 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 100 140 25 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 600 300 25 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 400 500 20 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 500 600 25 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 400 300 20 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 400 700 17 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 300 350 25 4 ")
PROCgr("rgb "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" "+STR$(FNroll(150)+100)+" size 3 sphere 500 400 25 4 ")
WAIT 40
UNTIL FALSE
ENDIF
IF m$="Graphics Demo" THEN
PROCcolor("b","000,000,000"):REM set background color to black
PROCgr("cls color red rect 500 550 550 600 move 500 500 print press amd hold LEFT/RIGHT arrows to see some angles : rgb 200 200 160 button 650 650 30")
PROCgr("sbox 0 0 400 400 15"):REM x,y,h,v,color
PROCgr("size 3 sphere 800 100 100 2 "):REM x y size di
PROCgr("rgb 200 200 250 size 2 ellipse 1000 800 100 50 3"): REM x,y, size w size h dimmer
REM I made the following BMP and mask controls the same layout to make it default layout
PROCgr("savebmp ball 700 0 200 200"):REM x y sizewide size height
PROCgr("loadbmp ball 900 0 200 200"):REM x y sizewide size height
PROCgr("size 3 donut 800 900")
PROCgr("rgb 200 200 200 ring 200 100 100 800 150 100 2"):REM CenterH CenterV locx locy size thickness dimmer
PROCgr("rgb 200 50 200 ring 10 20 1100 600 200 100 2"):REM a bit complex but cool
PROCgr("rgb 50 145 50 ring 50 200 1250 800 200 100 2")
PROCgr("mask 900 0 200 200"):REM x y sizewide size height (not the same as DEFPROCmask layout)
PROCgr("savebmp ballmask 900 0 200 400"):REM making a mask doubles height
PROCgr("loadbmp ballmask 1100 0 200 400")
PROCgr("rgb 250 100 100 size 2 block 800 800 25 5 rgb 200 200 250 size 2 block 1000 900 25 5")
PROCgr("set 500 1000 rgb 230 100 100 set 500 900"):REM set color is controlled by rgb
PROCgr("move 30 50 "):REM print requires a : at end of your statement and must have space because : is a key word
PROCgr("eyes 850 120 up 1") :REM x y , location of iris, speed of eye movement.. higher =slower
PROCgr("eyes 850 120 left 1"): PROCgr("eyes 850 120 down 1"): PROCgr("eyes 850 120 right 1"): PROCgr("eyes 850 120 center 1")
PROCgr("size 1 up c 15 ne 800 w 200 down e 50 se 50 s 50 sw 50 w 50 nw 50 n 50 ne 50 up se 5 fill 15")
PROCgr("size 3 up l 45 f 650 down")
PROCgr("say retrolib is becoming a powerful tool :")
PROCgr("say not all tools are demonstrated and more will be demonstrated on retrolib ten")
REPEAT
WAIT 10
IF INKEY(-26) THEN
IF d%=1 THEN an%=0
an%=an%-1: PROCgr("cls up move 500 500 r "+STR$(an%)+" "+"down f 50 r 45 f 50 r 45 f 50 r 45 f 50 r 45 f 50 r 45 f 50 r 45 f 50 r 45 f 50 r 45 f 50"):d%=2: IF an%< 0 THEN an%=360
ENDIF
IF INKEY(-122) THEN
IF d%=2 THEN an%=0
an%=an%+1:PROCgr("cls up move 500 500 r "+STR$(an%)+" "+"down f 50 r 45 f 50 r 45 f 50 r 45 f 50 r 45 f 50 r 45 f 50 r 45 f 50 r 45 f 50 r 45 f 50"):d%=1: IF an%> 360 THEN an%=0
ENDIF
UNTIL FALSE
REPEAT
PROC_block(600,600,40,200,200,255,4)
IF FNkey= " " THEN PROC_block(600,600,40,255,200,200,4):WAIT 20
MOVE 0,0
UNTIL FALSE
ENDIF
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.
IF m$="Exercise" THEN
PROCgr("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 ")
ENDIF
PROC_comexit
END
PROCcloseall
END
REM FNabutton added October 22 2017 (modified December 29, 2019)
DEFFNabutton(x,y,size%,c$,com$)
MOUSE mx,my,mb
LOCAL ret$
GCOL 5
RECTANGLE x,y,size%,size%
IF com$="fill" THEN
GCOL VAL(c$)
FILL x+5,y+5
ENDIF
IF mx>x AND mx<x+size% AND my>y AND my<y+size% THEN
GCOL 15: RECTANGLE x,y,size%,size%
IF mb=4 THEN ret$=com$
ENDIF
=ret$
REM TYPE input tool added March 2018
DEF FNtype(x%,y%)
REM first define a efficient array a&() and retstr$- case of empty returned string
LOCAL a&(),retstr$,h%,v%,t&,k$,cp&,bc$,fc$
h%=x%:v%=y%
fc$="000,000,000":bc$="200,200,200":REM text color is black
REM l%,cp% line # and cursor position.l%- future(not used yet)
REM bc$-(text overwrite-background) fc$-foreground text colors-
REM now give a&() a dimension of 100
DIM a&(100)
REPEAT
h%=x%
REPEAT
k$=INKEY$(4)
REM Cursor
PROCcolor("f",fc$):MOVE cp&*16+h%,v%:PRINT"_"
WAIT 10:REM seems pretty smooth
PROCcolor("f",bc$):MOVE cp&*16+h%,v%:PRINT"_"
UNTIL k$<>""
IF k$<>"" THEN
IF ASC(k$)>31 AND ASC(k$)<127 AND cp&<100 THEN
a&(cp&)=ASC(k$):cp&=cp&+1
ENDIF
h%=x%:v%=y%:REM test
MOVE h%,v%:PROCcolor("f",bc$)
REM print every ascii value in a&() array except 0 -cool stuff
PRINT $$^a&(0)
t&=0
h%=x%:v%=y%:REM test
MOVE h%,v%:PROCcolor("f",fc$)
PRINT $$^a&(0)
t&=0
ENDIF
IF ASC(k$)=8 AND cp&>0 THEN
t&=0
h%=x%:v%=y%:REM test
MOVE h%,v%:PROCcolor("f",bc$)
PRINT $$^a&(0)
t&=0
t&=cp&-1
REPEAT
a&(t&)=a&(t&+1)
t&+=1
UNTIL t&=100
t&=0
h%=x%:v%=y%:REM test
MOVE h%,v%:PROCcolor("f",fc$)
PRINT $$^a&(0)
t&=0
cp&-=1
ENDIF
UNTIL ASC(k$)=13
retstr$ = $$^a&(0)
t&=0:PROCresetrgb
=retstr$
REM arrowu(x,y) added October 22,2017
DEFPROCarrowu(x,y)
PRIVATE xx,yy
PROCcolor("f","black")
LINE xx,yy,xx-20,yy-20
LINE xx,yy,xx+20,yy-20
PROCcolor("f","15")
LINE x,y,x-20,y-20
LINE x,y,x+20,y-20
xx=x:yy=y
ENDPROC
REM arrowd(x,y) added October 22,2017
DEFPROCarrowd(x,y)
PRIVATE hh,vv
PROCcolor("f","000,000,000")
LINE hh,vv,hh-20,vv+20
LINE hh,vv,hh+20,vv+20
PROCcolor("f","15")
LINE x,y,x-20,y+20
LINE x,y,x+20,y+20
hh=x:vv=y
ENDPROC
REM game keys check (experimental) FAILED needs work
DEFFNgkey
LOCAL rk$
IF INKEY(-66) THEN rk$="A"
IF INKEY(-82) THEN rk$="S"
IF INKEY(-51) THEN rk$="D"
IF INKEY(-34) THEN rk$="W"
IF INKEY(-74) THEN rk$="ENTER"
IF INKEY(-99) THEN rk$="SPACE"
IF INKEY(-26) THEN rk$="LEFT"
IF INKEY(-122) THEN rk$="RIGHT"
IF INKEY(-58) THEN rk$="UP"
IF INKEY(-42) THEN rk$="DOWN"
=rk$
REM the following code is RETROLIB.. created by Michael J Gallup with contributions from Zaphod (code structure improvement
REM and Richard Russell (word interpreter / tools)
REM the world is free to use it ( including myself ) to help become more productive.
REM *******************************************************************************
REM NEW shaded edged block
DEFPROCslate(x%,y%,size%,r%,g%,b%)
LOCAL cun%,r$,g$,b$,cd%
FOR cun%=120 TO 0 STEP-11
PROCcrgb(r%-cun%,g%-cun%,b%-cun%)
PROCrect(x%+cd%,y%+cd%,x%+size%-cd%,y%+size%-cd%)
cd%+=1
NEXT cun%
r$=FNnumstr(r%):g$=FNnumstr(g%):b$=FNnumstr(b%)
PROCpaint(x%+cd%+1,y%+cd%+1,r$+","+g$+","+b$)
ENDPROC
REM example FNroll(150) gives a random number between 1 and 150 ************* just another tool
DEFFNroll(r)
rt%=RND(r)
=rt%
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%)
REM ENDPROC
ENDIF
ENDPROC
DEFPROCturtle(coun%,angle,pen$,RETURN x%,RETURN y%)
PRIVATE sx%,sy%
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%,r$,g$,b$,di%,di$,amt$,name$,h%,v%,resp$,speed$,speed,amt%
REPEAT
word$ = FNword(cmd$)
CASE word$ OF
WHEN "color" : c$=FNword(cmd$) : PROCcolor("f",c$)
WHEN "r" : angle=angle - VAL(FNword(cmd$))
WHEN "l" : angle=angle + VAL(FNword(cmd$))
WHEN "f" : PROCturtle(VAL(FNword(cmd$)),angle,pen$,x%,y%)
WHEN "rect" : x$=FNword(cmd$):y$=FNword(cmd$):h$=FNword(cmd$):v$=FNword(cmd$) :PROCrect(VAL(x$),VAL(y$),VAL(h$),VAL(v$))
WHEN"graphics" : PROCgraphics(1000,600)
WHEN"mask" : 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%)
WHEN"size" : size$=FNword(cmd$):PROCdotsize(VAL(size$))
WHEN"donut" :x$=FNword(cmd$):x%=VAL(x$):y$=FNword(cmd$):y%=VAL(y$):PROC_donut(x%,y%,r%,g%,b%)
WHEN"move" :
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)
WHEN"ellipse" :
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$))
WHEN"print" : PROCpr(lx%,ly%,FNbuild(cmd$),"15")
WHEN"say" : PROCspeak(FNbuild(cmd$),Pitch%,Speed%,Voice$)
WHEN"rgb" :
r$=FNword(cmd$):g$=FNword(cmd$):b$=FNword(cmd$)
r%=VAL(r$):g%=VAL(g$):b%=VAL(b$)
PROCcrgb(r%,g%,b%)
WHEN"block" :
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$))
REM button x y di
WHEN"button" :
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%)
WHEN"sbox" :
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$)
WHEN"sphere" :
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$))
WHEN"savebmp" :
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%)
WHEN"loadbmp" :
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%)
WHEN"ring" : ch$=FNword(cmd$):cv$=FNword(cmd$):x$=FNword(cmd$):y$=FNword(cmd$):size$=FNword(cmd$):size2$=FNword(cmd$):di$=FNword(cmd$)
PROC_ellipsering(VAL(ch$),VAL(cv$),VAL(x$),VAL(y$),VAL(size$),VAL(size2$),r%,g%,b%,VAL(di$))
WHEN"eyes" :
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
WHEN "c","n","s","e","w","ne","nw","se","sw","fill" :
resp$=word$
amt$=FNword(cmd$)
amt%=VAL(amt$)
PROCgo(resp$,amt%)
WHEN "up","down" : pen$=word$:PROCgo(word$,0)
REM LMFAO !!! set is crazy
WHEN "set" : x$=FNword(cmd$):y$=FNword(cmd$):PROCset(VAL(x$),VAL(y$),STR$(VAL(FNnumstr(r%)))+","+STR$(VAL(FNnumstr(g%)))+","+STR$(VAL(FNnumstr(b%)))+"")
WHEN"cls" : CLG
ENDCASE
UNTIL word$ = ""
ENDPROC
DEF FNbuild(a$) :REM Used by PROCgr
LOCAL b$,build$
REPEAT
b$= FNword(a$)
IF b$<>":" THEN build$+=" "+b$
UNTIL b$="" OR INSTR(":.?",RIGHT$(b$))>0
=build$
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
REM modified JANUARY 8,2020
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
REM modified JANUARY 8,2020
DEFPROC_sphere(h%,v%,size%,r%,g%,b%,di%)
LOCAL x%,skip%
skip%=FALSE
FOR x%=0 TO size%
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
REM modified JANUARY 8,2020
DEF PROC_ellipsering(centerh%,centerv%,h%,v%,size%,thickness%,x%,c%,a%,di%)
IF size% > thickness% THEN size% = thickness%
LET oc%=thickness%/2
LET outcenterh%=centerh%+oc%
LET outcenterv%=centerv%+oc%
LET r%=0
LET 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
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
DEF PROCellipse(h,v,sizex,sizey,x,c,a,di):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
COLOUR 0,x,c,a :GCOL 0
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-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
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
DEFPROClefteye(x,y,location$,speed) : PRIVATE dx,dy,counx,couny,eyeh,eyev,seyeh,seyev
IF counx<x-12 THEN counx=x-12:REM this ensures the pupil stays within eye
IF counx>x+12 THEN counx=x+12
IF couny<y-12 THEN couny=y-12
IF couny>y+12 THEN couny=y+12
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,20
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%)
REM Simplified. Line draws the right color and right length now. Much faster. Zaphod
PRIVATE x%,y%,pen%,c$
REM x% ,y% are already in @vdu.p.x%, @vdu.p.y% so are not needed to be kept separately as PRIVATE variables
REM @vdu.g.x has all the color details. BB4W Help "System Variables"
LOCAL xinc%,yinc%,dist%
CASE cm$ OF
WHEN "up" : pen%=1
WHEN "down" : pen%=0
WHEN "fill" : PROCpaint(x%,y%,STR$(coun%))
WHEN "c" : c$=STR$(coun%):PROCcolor("f",c$)
ENDCASE
dist%=INT(coun%/SQR(2)+0.5) REM round to the nearest pixel for 45° angles
CASE cm$ OF
WHEN "n" : yinc%=coun% : xinc%=0
WHEN "s" : yinc%=-coun% : xinc%=0
WHEN "e" : yinc%=0 : xinc%=coun%
WHEN "w" : yinc%=0 : xinc%=-coun%
WHEN "ne" :yinc%=dist% : xinc%=dist%
WHEN "nw" :yinc%=dist% : xinc%=-dist%
WHEN "sw" :yinc%=-dist% : xinc%=-dist%
WHEN "se" :yinc%=-dist% : xinc%=dist%
ENDCASE
IF pen% =0 IF (ABS(yinc%)+ABS(xinc%))<>0 THEN LINE x%,y%,x%+xinc%,y%+yinc%
x%+=xinc%:y%+=yinc%
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%)
r%=rgb% AND &FF
g%=rgb%>>8 AND &FF
b%=rgb%>>16 AND &FF
ENDPROC
REM experimental
DEFFNrgb(x%,y%)
LOCAL rgb%, r&, g&, b&
rgb%=TINT(x%,y%)
r&=rgb% :REM Use byte variable as mask.
g&=rgb% >>8
b&=rgb% >>16
=FNnumstr(r&)+","+FNnumstr(g&)+","+FNnumstr(b&)
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
REM used by PROCpr to enhance clean up from text overlays
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
ENDPROC
REM H,V,TEXTLIMIT (simpler?)
DEF FNinput(bx,by,textlimit)
LOCAL fill,MESSAGE$
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$)
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$
REM Modified on JANUARY 5, 2020
DEFFNbuttonz(X,Y,msg$)
LOCAL initialx%,fi%,reduction%,tx,ty,mx%,my%,mb%,ad%,ady%,c$
PRIVATE st$
VDU 5
IF msg$<> "clearitall" THEN
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$="15"
IF mb%=4 THEN st$=msg$
ELSE c$="7"
ENDIF
IF POINT(X,Y)=0 THEN c$="7"
GCOL VAL(c$):REM um you may ask why I am doing it this way
IF POINT(X,Y)<>VAL(c$) THEN
FOR fi%=12 TO 48
LINE X-3,Y+20-fi%,X+initialx%+8,Y+20-fi%
NEXT
GCOL 0
MOVE tx,ty
PRINT msg$
ENDIF
ENDIF
IF msg$="clearitall" THEN st$=""
COLOUR 0,0,0,0
MOVE 0,0 REM hide that thing
=st$
DEFFNstcorecol(wdnum$)
PROCresetrgb
LOCAL tcol%
CASE wdnum$ OF
WHEN "0","black" :tcol%=0
WHEN "1","red" :tcol%=1
WHEN "2","green" :tcol%=2
WHEN "3","yellow" :tcol%=3
WHEN "4","blue" :tcol%=4
WHEN "5","magneta" :tcol%=5
WHEN "6","cyan":tcol%=6
WHEN "7","white":tcol%=7
WHEN "8","grey":tcol%=8
WHEN "9","light red":tcol%=9
WHEN "10","light green":tcol%=10
WHEN "11","light yellow":tcol%=11
WHEN "12","light blue":tcol%=12
WHEN "13","light magneta":tcol%=13
WHEN "14","light cyan":tcol%=14
WHEN "15","light white" :tcol%=15
ENDCASE
=tcol%
DEF PROCfcolor(co$)
LOCAL rcol%
rcol%=FNstcorecol(co$)
GCOL rcol%
ENDPROC
DEF PROCbcolor(co$)
LOCAL rcol%
rcol%=FNstcorecol(co$)
GCOL 128 +rcol%
ENDPROC