Post by Admin on Jul 30, 2018 21:16:22 GMT
This is an ongoing project:
PROCgraphics(250,250)
n$="":REM Create calculator
PROCsbox(1,1,499,499,"white")
PROCsbox(40,420,480,480,"140,140,140"):REM LED display on calculator
ret$= FNabutton(40,50,50,"100,100,100","fill") :REM 0
GCOL 15:MOVE 60,80:PRINT "0"
ret$= FNabutton(120,50,50,"100,100,100","fill"):REM .
GCOL 15:MOVE 140,80:PRINT "."
REM ret$= FNabutton(200,50,50,"100,100,100","fill"):REM +/-
ret$= FNabutton(300,70,100,"150,150,150","fill"):REM +
GCOL 15:MOVE 345,125: PRINT"+"
ret$= FNabutton(430,50,50,"150,150,150","fill"): REM =
GCOL 15:MOVE 450,80:PRINT"="
ret$= FNabutton(430,120,50,"150,150,150","fill"):REM -
GCOL 15:MOVE 450,150:PRINT "-"
ret$= FNabutton(40,120,50,"100,100,100","fill"):REM 1
GCOL 15:MOVE 60,150:PRINT "1"
ret$= FNabutton(40,190,50,"100,100,100","fill"):REM 4
GCOL 15:MOVE 60,220:PRINT "4"
ret$= FNabutton(40,260,50,"100,100,100","fill"):REM 7
GCOL 15:MOVE 60,290:PRINT "7"
ret$= FNabutton(40,330,50,"200,100,100","fill"):REM ON/C
GCOL 15:MOVE 50,360:PRINT"CE"
ret$= FNabutton(120,120,50,"100,100,100","fill"):REM 2
GCOL 15:MOVE 140,150: PRINT"2"
ret$= FNabutton(120,190,50,"100,100,100","fill"):REM 5
GCOL 15:MOVE 140,220:PRINT"5"
ret$= FNabutton(120,260,50,"100,100,100","fill"):REM 8
GCOL 15:MOVE 140,290:PRINT"8"
ret$= FNabutton(200,120,50,"100,100,100","fill"):REM 3
GCOL 15:MOVE 220,150:PRINT"3"
ret$= FNabutton(200,190,50,"100,100,100","fill"):REM 6
GCOL 15:MOVE 220,220:PRINT"6"
ret$= FNabutton(200,260,50,"100,100,100","fill"):REM 9
GCOL 15:MOVE 220,290:PRINT"9"
ret$= FNabutton(350,190,50,"150,150,150","fill"):REM X
GCOL 15:MOVE 370,220
PRINT "x"
ret$= FNabutton(430,190,50,"150,150,150","fill"):REM /
GCOL 15:MOVE 450,220 :PRINT"/"
REM Begin button activity checks
* REFRESH OFF
REPEAT
REM ret$= FNabutton(200,50,50,"100,100,100","fill"):REM +/-
IF FNabutton(300,70,100,"150,150,150","+")="+" THEN op$="+":REM +
IF FNabutton(430,50,50,"150,150,150","=")= "=" THEN op$="=": REM =
IF FNabutton(430,120,50,"150,150,150","-")="-" THEN op$="-":REM -
IF FNabutton(350,190,50,"150,150,150","X")="X" THEN op$="X":REM X
IF FNabutton(430,190,50,"150,150,150","/")="/" THEN op$="/":REM /
IF FNabutton(40,330,50,"200,100,100","ON")="ON" THEN op$="ON":n$="":REM ON/C
PROCnumpad
GCOL 15:MOVE 50,470:PRINT n$
* REFRESH
WAIT 10
REM 140,140,140 is the background color of the LED display on the calculator
PROCcolor("f","140,140,140"):MOVE 50,470:PRINT n$
UNTIL FALSE
END
DEFPROCnumpad
IF FNabutton(120,50,50,"100,100,100",".")="." THEN n$=n$+".":REM .
IF FNabutton(40,50,50,"100,100,100","0")="0" THEN n$=n$+"0" :REM 0
IF FNabutton(40,120,50,"100,100,100","1")="1" THEN n$=n$+"1" :REM 1
IF FNabutton(40,190,50,"100,100,100","4")="4" THEN n$=n$+"4":REM 4
IF FNabutton(40,260,50,"100,100,100","7")="7" THEN n$=n$+"7":REM 7
IF FNabutton(120,120,50,"100,100,100","2")="2" THEN n$=n$+"2":REM 2
IF FNabutton(120,190,50,"100,100,100","5")="5" THEN n$=n$+"5":REM 5
IF FNabutton(120,260,50,"100,100,100","8")="8" THEN n$=n$+"8":REM 8
IF FNabutton(200,120,50,"100,100,100","3")="3" THEN n$=n$+"3":REM 3
IF FNabutton(200,190,50,"100,100,100","6")="6" THEN n$=n$+"6":REM 6
IF FNabutton(200,260,50,"100,100,100","9")="9" THEN n$=n$+"9":REM 9
ENDPROC
REM I put resetrgb back into the library because VDU 20 clears the screen.
DEFPROCresetrgb
LOCAL N
FOR N = 0 TO 15
VDU 19,N,N,0,0,0
NEXT N
VDU 20
ENDPROC
REM FNabutton added October 22 2017
DEFFNabutton(x,y,size%,c$,com$)
LOCAL _mx,_my,_mb,ret$
MOUSE _mx,_my,_mb
PROCcolor("f","5")
PROCrect(x,y,x+size%,y+size%)
IF com$="fill" THEN
PROCpaint(x+5,y+5,c$)
ENDIF
IF _mx>x AND _mx<x+size% AND _my>y AND _my<y+size% THEN
GCOL(15):PROCrect(x,y,x+size%,y+size%)
IF _mb=4 THEN ret$=com$
ENDIF
=ret$
REM arrowu(x,y) added October 22,2017
DEFPROCarrowu(x,y)
LOCAL _xx,_yy
VDU 20:GCOL 0
LINE _xx,_yy,_xx-20,_yy-20
LINE _xx,_yy,_xx+20,_yy-20
GCOL 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
VDU 20:GCOL 0
LINE _hh,_vv,_hh-20,_vv+20
LINE _hh,_vv,_hh+20,_vv+20
GCOL 15
LINE x,y,x-20,y+20
LINE x,y,x+20,y+20
_hh=x:_vv=y
ENDPROC
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)
LOCAL r_t%
r_t%=RND(r)
=r_t%
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%,c_h$,l_ocation$,fx,c_v$
LOCAL r%,g%,b%
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%,VAL(r$),VAL(g$),VAL(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$),VAL(r$),VAL(g$),VAL(b$),VAL(di$))
WHEN"print" : PROCpr(lx%,ly%,FNbuild(cmd$),"15")
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" : c_h$=FNword(cmd$):c_v$=FNword(cmd$):x$=FNword(cmd$):y$=FNword(cmd$):size$=FNword(cmd$):size2$=FNword(cmd$):di$=FNword(cmd$)
PROC_ellipsering(VAL(c_h$),VAL(c_v$),VAL(x$),VAL(y$),VAL(size$),VAL(size2$),r%,g%,b%,VAL(di$))
WHEN"eyes" :
x$=FNword(cmd$):y$=FNword(cmd$):l_ocation$=FNword(cmd$):speed$=FNword(cmd$):speed=VAL(speed$)
FOR fx=1 TO 40:PROClefteye(VAL(x$),VAL(y$),l_ocation$,speed):PROCrighteye(VAL(x$)-100,VAL(y$),l_ocation$,speed):NEXT fx
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,b_egin,s_ize,x,c,a,d_i)
REM restore default color palettes
PROCresetrgb:GCOL 0
LOCAL r,g,b,p,ny
r=x
g=c
b=a
p=s_ize-b_egin
p=p/2
p=b_egin+p
FOR ny=p TO s_ize
COLOUR 0,x,c,a :GCOL 0
LINE h-ny,v-ny,h+ny,v-ny
LINE h+ny,v-ny,h+ny,v+ny
LINE h+ny,v+ny,h-ny,v+ny
LINE h-ny,v+ny,h-ny,v-ny
x=x-d_i
c=c-d_i
a=a-d_i
IF x<2 THEN x=2
IF c<2 THEN c=2
IF a<2 THEN a=2
NEXT ny
p=s_ize-b_egin
p=p/2
p=b_egin+p
FOR ny=b_egin TO p
COLOUR 1,x,c,a :GCOL 1
LINE h-ny,v-ny,h+ny,v-ny
LINE h+ny,v-ny,h+ny,v+ny
LINE h+ny,v+ny,h-ny,v+ny
LINE h-ny,v+ny,h-ny,v-ny
x=x+d_i
c=c+d_i
a=a+d_i
NEXT ny
PROCpaint(h,v,FNnumstr(r)+" "+FNnumstr(g)+" "+FNnumstr(b))
ENDPROC
DEF PROC_block(h,v,s,x,c,a,d_i)
LOCAL p,y
p=s/2
FOR y=1 TO s
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-d_i
c=c-d_i
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,r,g,b)
PROC_ellipsering(3,3,h,v,30,40,r,g,b,10)
PROC_sphere(h,v,10,r,g,b,7)
ENDPROC
DEF PROC_ellipsering(ch,cv,h,v,s,t,x,c,a,d_i)
LOCAL oc,och,ocv,r,dc,ny
IF s > t THEN s = t
oc=t/2
och=ch+oc
ocv=cv+oc
r=0
dc=s/2
FOR ny=1 TO dc
COLOUR 1,x,c,a GCOL 1
ELLIPSE h,v,och-r,ocv-r
ELLIPSE h,v,och+r,ocv+r
r=r+1
x=x-d_i
c=c-d_i
a=a-d_i
IF x<2 THEN x=2
IF c<2 THEN c=2
IF a<2 THEN a=2
NEXT ny
ENDPROC
REM ellipse h,v,sizex,sizey,R,G,B,dimmer
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
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-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
DEFPROC_sphere(h,v,s,r%,g%,b%,d_i%)
LOCAL x%,skip%
PROCdotsize(3)
skip%=FALSE
FOR x%=0 TO s
r%=r%-d_i%
g%=g%-d_i%
b%=b%-d_i%
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%
PROCdotsize(1)
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) - simple?
DEF PROCgraphics(x,y)
VDU 23,22,x;y;8,15,16,1
OFF
VDU 5
ENDPROC
DEFFNkey
LOCAL r$
r$=INKEY$(4)
=r$
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
VDU 20
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
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)
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%,r$
cov$=STR$(num)
l%=LEN(cov$)
IF l%=1 THEN r$="00"+cov$
IF l%=2 THEN r$="0"+cov$
IF l%=3 THEN r$=cov$
=r$
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 "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 FN_input(bx,b_y,textlimit)
LOCAL f_ill,message$,mes$,cey$,s_l%,i_tialx%
i_tialx%=0:s_l%=0:cey$="":message$="":mes$=""
i_tialx%=textlimit*16.2
FOR f_ill=1 TO 58
PROCcolor("f","15"):LINE bx+3,b_y+20-f_ill,bx+i_tialx%,b_y+20-f_ill
NEXT f_ill
PROCcolor("f","0"):LINE bx+3,b_y+20,bx+i_tialx%,b_y+20:LINE bx+3,b_y+20-f_ill,bx+i_tialx%,b_y+20-f_ill:
REPEAT
REPEAT
cey$ =INKEY$(1)
PROCcolor("F","0")
MOVE bx,b_y:PRINT message$;"_" :* REFRESH
s_l%=LEN(message$)
UNTIL cey$ <>""
s_l%=LEN(message$)
IF INKEY(-48) s_l%=LEN(message$)-1:cey$=""
REPEAT UNTIL INKEY(0)=-1
IF s_l%<LEN(message$) THEN
PROCcolor("F","15")
MOVE bx,b_y
PRINT message$;"_"
ENDIF
mes$=MID$(message$,0,s_l%)
message$=mes$
PROCcolor("F","15"):MOVE bx,b_y:PRINT message$;"_"
IF LEN(cey$) = 1 THEN
IF LEN(message$)<textlimit THEN PROCcolor("F","15"):MOVE bx,b_y:PRINT message$;"_": message$=message$+cey$:* REFRESH OFF
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$
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$="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
ENDIF
IF msg$="clearitall" THEN st$=""
MOVE 0,0 REM hide that thing
=st$
DEFFNstcorecol(wdnum$)
VDU 20
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
/code]