Post by Admin on Apr 1, 2018 19:42:09 GMT
BBC BASIC FOR Windows version only
10 INSTALL @lib$+"SPRITELIB"
20 cy%=0:di%=0:xf%=0:yf%=0:xff%=0:yff%=0:mx%=0:my%=0:mb%=0:pass%=0:chk1$="":chk2$="":chk3$="":cyff%=0:cxff%=0
30 scx%=0:scy%=0:score%=0
40 REM JAN 1 2017
50 REM RETROLIB 11 with FNgkey and my board game (has texture filler shader)
60 INSTALL @lib$+"COMLIBA"
70 ON ERROR PROC_comexit : PRINT 'REPORT$ : END
80 ON CLOSE PROC_comexit :PROC_exitsprites:QUIT
90 PROC_cominit
100 Pitch% = 0
110 Speed% = 0
120 Voice$ = ""
130 m$="":v%=0
140 an%=0
150 d%=0:d%=1:ti%=0:rt%=0:ub%=0:u%=0
160 reply$="":tic%=0 :reply%=0
170 REM inserted program here to test buttonz tool
180 PROCgraphics(1000,600)
190 IF FN_initsprites(10) = 0 STOP
200 REM PROCslate(0,0,150,150,150,180)
210 REM PROCbcolor("0"):PROCfcolor("0"):RECTANGLE FILL 20,20,110,110
220 REM PROCfcolor("0"):RECTANGLE FILL 0,150,150,150
230 REM PROCfcolor("15"):RECTANGLE FILL 20,170,110,110
240 REM mask must be before _getbmp.. otherwise it wont update
250 REM sprite #, x,y, 0=off 1= on !!!!!!!
260 REM WAIT 100
270 REM PROCgr("savebmp slate 0 0 150 300")
280 PROC_getbmp(9,"frame")
290 PROC_getbmp(8,"framed")
300 REM PROCgameboard(5,5,150,150,180,"plain")
310 REM PROCgr("savebmp board 0 0 1225 1195")
320 PROCgr("cls loadbmp board 0 0 1225 1195")
330 PROCnewmix
340 luk$="":st$=""
350 PROCgr("move 100 1150 rgb 200 200 200 print Volatile Vases CREATED BY Michael J Gallup ")
360 PROCgr("move 100 1100 print SCORE ")
370 REPEAT
380 IF pass%=0 THEN PROC_putspriteframe(9,xf%,yf%,1)
390 IF pass%=0 THEN PROC_putspriteframe(8,xff%,yff%,1)
400 luk$=FNgkey
410 MOUSE mx%,my%,mb%
420 IF mb%=4 THEN
430 IF mx%>0 AND mx%<1200 AND my%>0 AND my%<1100 THEN
440 IF mx%>xf% +150 AND my%>yf% THEN yf%+=150:xf%+=150
450 IF mx%>xf% +150 AND my%<yf% THEN xf%+=150
460 IF mx%>xf% AND mx%<xf%+150 THEN
470 IF my%< yf%+150 THEN yf%-=150
480 IF my%> yf%+150 THEN yf%+=150
490 ENDIF
500 IF mx%<xf% AND my%< yf%+150 AND my%>yf%-150 THEN xf%-=150
510 ENDIF
520 ENDIF
530 IF mb%=1 THEN
540 IF mx%>0 AND mx%<1200 AND my%>0 AND my%<1100 THEN
550 IF mx%>xff% +150 AND my%>yff% THEN yff%+=150:xff%+=150
560 IF mx%>xff% +150 AND my%<yff% THEN xff%+=150
570 IF mx%>xff% AND mx%<xff%+150 THEN
580 IF my%< yff%+150 THEN yff%-=150
590 IF my%> yff%+150 THEN yff%+=150
600 IF yff%>900 THEN yff%=900
610 ENDIF
620 IF mx%<xff% AND my%< yff%+150 AND my%>yff%-150 THEN xff%-=150
630 ENDIF
640 ENDIF
650 IF luk$="UP" OR luk$="W" THEN yf%+=150:WAIT 12
660 IF yf%>900 THEN yf%=900
670 IF luk$="RIGHT" OR luk$="D" THEN xf%+=150:WAIT 12
680 IF xf%>1050 THEN xf%=1050:IF xff%>1050 THEN xff%=1050
690 IF luk$="LEFT" OR luk$="A" THEN xf%-=150:WAIT 12
700 IF xf%<0 THEN xf%=0: IF xff%<0 THEN xff%=0
710 IF luk$="DOWN" OR luk$="S" THEN yf%-=150:WAIT 12
720 IF yf%<0 THEN yf%=0:IF yff%<0 THEN yff%=0
730 corri$=FNrgb(xf%+75,yf%+75)
740 luk$=""
750 st$=FNbuttonz(0,0,"clearitall")
760 st$=FNbuttonz(1300,1000,"SWAP ")
770 st$=FNbuttonz(1300,900,"GATHER ")
780 st$=FNbuttonz(1300,800,"NEXT BOARD ")
790 st$=FNbuttonz(1300,700,"HELP ")
800 IF st$="HELP " THEN
810 PROCsbox(1220,650,1980,0,"white")
820 PROCtype(1230,620,"* red/green selectors- mouse left/right","white")
830 PROCtype(1230,590,"! drag selectors to destinations !","white")
840 PROCtype(1230,530,"Red Selector-Origin/Left & Down GATHER","white")
850 PROCtype(1230,500,"Green- SWAP destination-must be L/R-U/D","white")
860 PROCtype(1230,470,"Grey is open to movement","white")
870 PROCtype(1230,430,"GATHER is from RIGHT to LEFT","white")
880 PROCtype(1230,400," and from TOP to bottom )","white")
890
900 ENDIF
910 IF st$="NEXT BOARD " THEN
920 PROCcolor("b","000,000,000")
930 PROCgr("cls loadbmp board 0 0 1225 1195")
940 PROCnewmix
950 luk$="":st$=""
960 PROCcolor("f","200,200,200")
970 PROCtype(100,1150," Volatile Pots CREATED BY Michael J Gallup ","200,200,200")
980 ENDIF
990 IF st$="GATHER " AND FNrgb(xf%+75,yf%+75) <> "150,150,180" THEN
1000 sweep%=0:dow%=0:upp%=0:rit%=0:lef%=0:scx%=xf%+75:scy%=yf%+75
1010 corri$=FNrgb(xf%+75,yf%+75)
1020 REPEAT
1030 scy%-=150
1040 IF FNrgb(scx%,scy%)= corri$ THEN dow%+=1
1050 UNTIL FNrgb(scx%,scy%)<> corri$
1060 IF dow%>1 THEN
1070 scy%-=75-150:scx%-=75
1080 FOR sweep%=0 TO dow%
1090 score%=score%+10
1100 PROCbcolor("0"):PROCcolor("f","150,150,180")
1110 RECTANGLE FILL scx%+15,scy%+15,125,125
1120 scy%+=150
1130 NEXT sweep%
1140 ENDIF
1150 dow%=0:scx=xf%+75:scy%=yf%+75
1160 REPEAT
1170 scx%-=150
1180 IF FNrgb(scx%,scy%)= corri$ THEN dow%+=1
1190 UNTIL FNrgb(scx%,scy%)<> corri$
1200 IF dow%>1 THEN
1210 scy%-=75:scx%-=75-150
1220 FOR sweep%=0 TO dow%
1230 score%=score%+10
1240 PROCbcolor("0"):PROCcolor("f","150,150,180")
1250 RECTANGLE FILL scx%+15,scy%+15,125,125
1260 scx%+=150
1270 NEXT sweep%
1280 dow%=0
1290 ENDIF
1300 PROCpr(100,1100,"SCORE "+STR$(score%)+"","230,230,200")
1310 ENDIF
1320 IF st$="SWAP " THEN
1330 chk1$="":chk2$="":chk3$="":chk4$="":pass%=0:cyff%=yff%+75:cxff%=xff%+75:rspr$="":uspr$="":lspr$="":dspr$=""
1340 chk1$=FNrgb(cxff%+150,cyff%):chk2$=FNrgb(cxff%,cyff%+150):chk3$=FNrgb(cxff%-150,cyff%):chk4$=FNrgb(cxff%,cyff%-150):
1350 IF xff%>xf%-200 AND yff%>yf%-200 AND xff%<xf%+230 AND yff%<yf%+230 THEN
1360 REM IF yff%>yf% AND xff%=xf% THEN
1370 REM IF xff%<xf% AND yff%=yf% THEN
1380 REM IF yff%<yf% AND xff%=xf% THEN
1390 mini%=0:REM if this is higher than 1 then move check1 is ok
1400 IF chk1$=corri$ THEN rspr$="right":mini%+=1
1410 IF chk2$=corri$ THEN uspr$="up":mini%+=1
1420 IF chk3$=corri$ THEN lspr$="left":mini%+=1
1430 IF chk4$=corri$ THEN dspr$="down":mini%+=1
1440 IF FNrgb(cxff%,cyff%)="150,150,180" THEN mini%=2
1450 IF mini%>1 THEN RECTANGLE SWAP xf%,yf%,150,150 TO xff%,yff%:SOUND 0,-15,100,1:WAIT 20
1460 ENDIF:mini%=0
1470 REM PROCgr("move 1300 600 rgb 200 200 200 print green "+STR$(cxff%)+","+STR$(cyff%)+"")
1480 REM PROCgr("move 1300 500 rgb 200 200 200 print red "+STR$(xf%)+","+STR$(yf%)+"")
1490 REM PROCgr("move 1300 400 print origin :"+corri$+" dest "+FNrgb(cxff%,cyff%)+"")
1500 REM PROCgr("move 900 1150 print R"+chk1$+",U"+chk2$+",L"+chk3$+",D"+chk4$+"")
1510 REM PROCgr("move 1300 200 print "+rspr$+","+uspr$+"")
1520 REM PROCgr("move 1300 100 print "+lspr$+","+dspr$+"")
1530 st$=""
1540
1550 ENDIF
1560 WAIT 1
1570 UNTIL FALSE
1580 PROC_exitsprites
1590 PROC_comexit
1600 END
1610 DEFPROC_putspriteframe(n%,X,Y,n%)
1620 PROC_movesprite(n%,X+5,Y+150,n%)
1630 ENDPROC
1640 REM this may slow things a bit, but I want to change it
1650 DEFPROC_getbmp(num%,bmpname$)
1660 LOCAL a%
1670 bmpname$+=".bmp"
1680 IF FN_createspritefrombmp(num%,bmpname$) = 0 THEN
1690 ERROR 100, "Couldn't create "+bmpname$+" sprite"
1700 ENDIF
1710 ENDPROC
1720 DEF PROCgameboard(lx%,ly%,gbr%,gbg%,gbb%,type$)
1730 LOCAL rt%,v%,ub%,u%
1740 REPEAT
1750 REPEAT
1760 PROCslate(lx%+rt%,ly%+ub%,150,gbr%,gbg%,gbb%)
1770 rt%+=150
1780 v%=FNcounter(8)
1790 UNTIL v%>0
1800 ub%+=150:u%+=1
1810 rt%=0
1820 UNTIL u%=7
1830 ENDPROC
1840 DEF PROCnewmix
1850 LOCAL cycy%,pr%,pg%,pb%,rres%
1860 FOR cycy% = 80 TO 980 STEP 150
1870 PROCshufflecol(pr%,pg%,pb%)
1880 PROCoval(80,cycy%,50,pr%,pg%,pb%)
1890 PROCshufflecol(pr%,pg%,pb%)
1900 PROCoval(230,cycy%,50,pr%,pg%,pb%)
1910 PROCshufflecol(pr%,pg%,pb%)
1920 PROCoval(380,cycy%,50,pr%,pg%,pb%)
1930 PROCshufflecol(pr%,pg%,pb%)
1940 PROCoval(530,cycy%,50,pr%,pg%,pb%)
1950 PROCshufflecol(pr%,pg%,pb%)
1960 PROCoval(680,cycy%,50,pr%,pg%,pb%)
1970 PROCshufflecol(pr%,pg%,pb%)
1980 PROCoval(830,cycy%,50,pr%,pg%,pb%)
1990 PROCshufflecol(pr%,pg%,pb%)
2000 PROCoval(980,cycy%,50,pr%,pg%,pb%)
2010 PROCshufflecol(pr%,pg%,pb%)
2020 PROCoval(1130,cycy%,50,pr%,pg%,pb%)
2030 NEXT cycy%
2040 ENDPROC
2050 DEFPROCshufflecol(RETURN pr%,RETURN pg%,RETURN pb%)
2060 LOCAL rres%
2070 rres%=FNroll(7)
2080 CASE rres% OF
2090 WHEN 0:pr%=150:pg%=150:pb%=250
2100 WHEN 1:pr%=200:pg%=190:pb%=190
2110 WHEN 2:pr%=250:pg%=155:pb%=150
2120 WHEN 3:pr%=150:pg%=250:pb%=150
2130 WHEN 4:pr%=250:pg%=250:pb%=250
2140 WHEN 5:pr%=200:pg%=150:pb%=150
2150 WHEN 6:pr%=150:pg%=255:pb%=255
2160 WHEN 7:pr%=250:pg%=250:pb%=150
2170 ENDCASE
2180 ENDPROC
2190 RETROLIB 11
2200 REM LATEST TEXTURE FILLER JAN 1 2017 (needs more development
2210 REM light%= distance before central light:x,y,h,v--work area:style$-"edge" or "light" or "curve":r%,g%,b% start palette
2220 REM eg : PROCcolor("f","225,255,255"):ELLIPSE FILL 100,70,100,200:PROCtexture(0,0,300,300,"light",20,225,255,255,1.4,1)
2230 DEFPROCtexture(x%,y%,h%,v%,style$,light%,r%,g%,b%,di,stagger%)
2240 LOCAL dx%,dy%,c$,counx%,couny%,pr%,pg%,pb%,rr,gg,bb
2250 pr%=r%:pg%=g%:pb%=b%
2260 counx%=0:couny%=0:rr=r%:gg=g%:bb=b%
2270 dx%= h%-x%
2280 dy%= v%-y%
2290 REM IF dx%>dy% OR dx%=dy% THEN
2300 REM REPEAT
2310 REM c$=FNrgb(x%+counx%,y%+couny%)
2320 REM IF c$<>"000,000,000" THEN PROCcolor("f",""+FNnumstr(r%)+","+FNnumstr(g%)+","+FNnumstr(b%)):PROCdotrgb(x%+counx%,y%+couny%+dy%+1)
2330 REM couny%+=1:IF couny%=y%+dy% THEN couny%=0:counx%=counx%+1
2340 REM r%=r%-di%:g%=g%-di%:b%=b%-di%
2350 REM UNTIL counx%=dx%+1
2360 REM ENDIF
2370 IF dy%>dx% OR dx%=dy% THEN
2380 REPEAT
2390 c$=FNrgb(x%+counx%,y%+couny%)
2400 IF c$<>"000,000,000" THEN PROCdotrgb(x%+counx%,y%+couny%+dy%+1,r%,g%,b%):IF r%>1 AND g%>1 AND b%>1 THEN rr=rr-di:gg=gg-di:bb=bb-di
2410 counx%+=2:IF counx%>=x%+dx% THEN counx%=0:couny%=couny%+2:r%=pr%:g%=pg%:b%=pb%:rr=r%:gg=g%:bb=b%:pr%=pr%-stagger%:pg%=pg%-stagger%:pb%=pb%-stagger%
2420 REM IF r%>1 AND g%>1 AND b%>1 THEN r%=r%-di%:g%=g%-di%:b%=b%-di%
2430 r%=rr:g%=gg:b%=bb
2440 UNTIL couny%>dy%
2450 ENDIF
2460 ENDPROC
2470 REM my custom counter
2480 DEFFNcounter(n%)
2490 PRIVATE cond%
2500 LOCAL retcond%
2510 cond%=cond%+1
2520 IF cond%=(n%) THEN retcond%=cond%:cond%=0
2530 =retcond%
2540 REM game keys check (experimental)
2550 DEFFNgkey
2560 LOCAL rk$
2570 IF INKEY(-66) THEN rk$="A"
2580 IF INKEY(-82) THEN rk$="S"
2590 IF INKEY(-51) THEN rk$="D"
2600 IF INKEY(-34) THEN rk$="W"
2610 IF INKEY(-74) THEN rk$="ENTER"
2620 IF INKEY(-99) THEN rk$="SPACE"
2630 IF INKEY(-26) THEN rk$="LEFT"
2640 IF INKEY(-122) THEN rk$="RIGHT"
2650 IF INKEY(-58) THEN rk$="UP"
2660 IF INKEY(-42) THEN rk$="DOWN"
2670 =rk$
2680 REM NEW shaded edged block
2690 DEFPROCslate(x%,y%,size%,r%,g%,b%)
2700 LOCAL cun%,r$,g$,b$,cd%
2710 FOR cun%=120 TO 0 STEP-11
2720 PROCcrgb(r%-cun%,g%-cun%,b%-cun%)
2730 PROCrect(x%+cd%,y%+cd%,x%+size%-cd%,y%+size%-cd%)
2740 cd%+=1
2750 NEXT cun%
2760 r$=FNnumstr(r%):g$=FNnumstr(g%):b$=FNnumstr(b%)
2770 PROCpaint(x%+cd%+1,y%+cd%+1,r$+","+g$+","+b$)
2780 ENDPROC
2790 DEFPROCoval(x%,y%,size%,r%,g%,b%)
2800 LOCAL cun%,r$,g$,b$,cd%,nd%
2810 PROCshade(x%,y%,size%-5)
2820 FOR cun%=130 TO 0 STEP-12
2830 PROCcrgb(r%-cun%,g%-cun%,b%-cun%)
2840 PROCgr("size 3")
2850 CIRCLE x%,y%+cd%,size%-cd%
2860 cd%+=2
2870 NEXT cun%
2880 PROCcrgb(r%-100,g%-100,b%-100)
2890 PROCgr("size 1")
2900 CIRCLE x%,y%+cd%-2,size%-cd%+5
2910 r$=FNnumstr(r%):g$=FNnumstr(g%):b$=FNnumstr(b%)
2920 PROCpaint(x%,y%+cd%,r$+","+g$+","+b$)
2930 nd%=cd%
2940 FOR cun%=50 TO 130 STEP 5
2950 PROCcrgb(r%-cun%,g%-cun%,b%-cun%)
2960 PROCgr("size 3")
2970 CIRCLE x%,y%+cd%-2,size%-nd%
2980 nd%+=2
2990 NEXT cun%
3000 ENDPROC
3010 REM for putting a shadow at base of image ***
3020 DEFPROCshade(xxx%,yyy%,spread%)
3030 LOCAL xr%,xg%,xb%,xcun%,xcd%
3040 xcd%=5
3050 PROCrgbret(xxx%,yyy%,xr%,xg%,xb%)
3060 PROCgr("size 2")
3070 FOR xcun%=70 TO 0 STEP-1
3080 PROCcrgb(xr%-xcun%,xg%-xcun%,xb%-xcun%)
3090 PROCgr("size 3")
3100 CIRCLE xxx%,yyy%-15,spread%-xcd%
3110 xcd%+=1
3120 NEXT xcun%
3130 ENDPROC
3140
3150 REM the following code is RETROLIB.. created by Michael J Gallup with contributions from Zaphod (code structure improvement
3160 REM and Richard Russell (word interpreter / tools)
3170 REM the world is free to use it ( including myself ) to help become more productive.
3180 REM example FNroll(150) gives a random number between 1 and 150 ************* just another tool
3190 DEFFNroll(r)
3200 rt%=RND(r)
3210 =rt%
3220 DEF PROCspeak(phrase$,pitch%,speed%,voice$)
3230 tts% = FN_createobject("Sapi.SpVoice")
3240 IF tts% THEN
3250 LOCAL qual$
3260 qual$ = "<PITCH ABSMIDDLE="""""+STR$pitch%+"""""/><RATE ABSSPEED="""""+STR$speed%+"""""/>"
3270 IF voice$<>"" qual$ += "<VOICE REQUIRED=""""NAME="+voice$+"""""/>"
3280 PROC_callmethod(tts%, "Speak("""+qual$+phrase$+""")")
3290 PROC_releaseobject(tts%)
3300 REM ENDPROC
3310 ENDIF
3320 ENDPROC
3330 DEFPROCturtle(coun%,angle,pen$,RETURN x%,RETURN y%)
3340 PRIVATE sx%,sy%
3350 IF pen$="move" THEN sx%=x%:sy%=y%
3360 IF pen$="up" OR pen$="down" THEN
3370 sx%+=coun%*COS(RAD(angle))
3380 sy%+=coun%*SIN(RAD(angle))
3390 IF pen$="down" THEN LINE x%,y%,sx%,sy%
3400 ENDIF
3410 x%=sx%:y%=sy%
3420 ENDPROC
3430 DEFPROCgr(cmd$)
3440 PRIVATE pen$,x%,y%,angle
3450 LOCAL x$,y$,h$,v$,c$,word$,size$,size2$,lx%,ly%,r$,g$,b$,di%,di$,amt$,name$,h%,v%,resp$,speed$,speed,amt%
3460 REPEAT
3470 word$ = FNword(cmd$)
3480 CASE word$ OF
3490 WHEN "color" : c$=FNword(cmd$) : PROCcolor("f",c$)
3500 WHEN "r" : angle=angle - VAL(FNword(cmd$))
3510 WHEN "l" : angle=angle + VAL(FNword(cmd$))
3520 WHEN "f" : PROCturtle(VAL(FNword(cmd$)),angle,pen$,x%,y%)
3530 WHEN "rect" : x$=FNword(cmd$):y$=FNword(cmd$):h$=FNword(cmd$):v$=FNword(cmd$) :PROCrect(VAL(x$),VAL(y$),VAL(h$),VAL(v$))
3540 WHEN"graphics" : PROCgraphics(1000,600)
3550 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$)
3560 PROCmask(x%,y%,h%,v%)
3570 WHEN"size" : size$=FNword(cmd$):PROCdotsize(VAL(size$))
3580 WHEN"donut" :x$=FNword(cmd$):x%=VAL(x$):y$=FNword(cmd$):y%=VAL(y$):PROC_donut(x%,y%,r%,g%,b%)
3590 WHEN"move" :
3600 x$=FNword(cmd$):y$=FNword(cmd$)
3610 lx%= VAL(x$)
3620 ly%= VAL(y$)
3630 x%=lx%:y%=ly%
3640 PROCturtle(0,angle,"move",x%,y%)
3650 PROCgo("move",0)
3660 WHEN"ellipse" :
3670 x$=FNword(cmd$):y$=FNword(cmd$):size$=FNword(cmd$):size2$=FNword(cmd$):di$=FNword(cmd$)
3680 PROCellipse(VAL(x$),VAL(y$),VAL(size$),VAL(size2$),r%,g%,b%,VAL(di$))
3690 WHEN"print" : PROCpr(lx%,ly%,FNbuild(cmd$),"15")
3700 WHEN"say" : PROCspeak(FNbuild(cmd$),Pitch%,Speed%,Voice$)
3710 WHEN"rgb" :
3720 r$=FNword(cmd$):g$=FNword(cmd$):b$=FNword(cmd$)
3730 r%=VAL(r$):g%=VAL(g$):b%=VAL(b$)
3740 PROCcrgb(r%,g%,b%)
3750 WHEN"block" :
3760 x$=FNword(cmd$):y$=FNword(cmd$):size$=FNword(cmd$):di$=FNword(cmd$)
3770 PROC_block(VAL(x$),VAL(y$),VAL(size$),r%,g%,b%,VAL(di$))
3780 REM button x y di
3790 WHEN"button" :
3800 x$=FNword(cmd$):y$=FNword(cmd$):di$=FNword(cmd$)
3810 x%=VAL(x$):y%=VAL(y$):di%=VAL(di$)
3820 PROC_button(x%,y%,15,25,r%,g%,b%,di%)
3830 WHEN"sbox" :
3840 x$=FNword(cmd$):y$=FNword(cmd$):h$=FNword(cmd$):v$=FNword(cmd$):
3850 c$=FNword(cmd$)
3860 PROCsbox(VAL(x$),VAL(y$),VAL(h$),VAL(v$),c$)
3870 WHEN"sphere" :
3880 x$=FNword(cmd$):y$=FNword(cmd$):size$=FNword(cmd$):di$=FNword(cmd$)
3890 PROC_sphere(VAL(x$),VAL(y$),VAL(size$),r%,g%,b%,VAL(di$))
3900 WHEN"savebmp" :
3910 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$)
3920 OSCLI "SCREENSAVE """+name$+""" "+STR$(x%)+","+STR$(y%)+","+STR$(h%)+","+STR$(v%)
3930 WHEN"loadbmp" :
3940 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$)
3950 OSCLI "DISPLAY """+name$+""" "+STR$(x%)+","+STR$(y%)+","+STR$(h%)+","+STR$(v%)
3960 WHEN"ring" : ch$=FNword(cmd$):cv$=FNword(cmd$):x$=FNword(cmd$):y$=FNword(cmd$):size$=FNword(cmd$):size2$=FNword(cmd$):di$=FNword(cmd$)
3970 PROC_ellipsering(VAL(ch$),VAL(cv$),VAL(x$),VAL(y$),VAL(size$),VAL(size2$),r%,g%,b%,VAL(di$))
3980 WHEN"eyes" :
3990 x$=FNword(cmd$):y$=FNword(cmd$):location$=FNword(cmd$):speed$=FNword(cmd$):speed=VAL(speed$)
4000 FOR x=1 TO 40:PROClefteye(VAL(x$),VAL(y$),location$,speed):PROCrighteye(VAL(x$)-100,VAL(y$),location$,speed):NEXT x
4010 WHEN "c","n","s","e","w","ne","nw","se","sw","fill" :
4020 resp$=word$
4030 amt$=FNword(cmd$)
4040 amt%=VAL(amt$)
4050 PROCgo(resp$,amt%)
4060 WHEN "up","down" : pen$=word$:PROCgo(word$,0)
4070 REM LMFAO !!! set is crazy
4080 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%)))+"")
4090 WHEN"cls" : CLG
4100 ENDCASE
4110 UNTIL word$ = ""
4120 ENDPROC
4130
4140 DEF FNbuild(a$) :REM Used by PROCgr
4150 LOCAL b$,build$
4160 REPEAT
4170 b$= FNword(a$)
4180 IF b$<>":" THEN build$+=" "+b$
4190 UNTIL b$="" OR INSTR(":.?",RIGHT$(b$))>0
4200 =build$
4210 REM thanks Richard
4220 DEF FNword(RETURN A$)
4230 PRIVATE Alphabet$
4240 LOCAL space$
4250 Alphabet$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"+"0123456789:,./"
4260 space$ = FNtoken(A$, " ")
4270 = FNtoken(A$,Alphabet$)
4280
4290 DEF FNtoken(RETURN A$, list$)
4300 LOCAL T$
4310 WHILE INSTR(list$, LEFT$(A$,1))
4320 T$ += LEFT$(A$,1)
4330 A$ = MID$(A$,2)
4340 ENDWHILE
4350 = T$
4360 REM made to force text regardless of what is there
4370 DEF PROCtype(X,Y,msg$,c$)
4380 LOCAL initialx%,fi%,reduction%,tx,ty
4390 initialx%=LEN(msg$)
4400 PROCcolor("f",c$)
4410 GCOL 0
4420 LET tx= X+initialx%+25
4430 LET ty= Y:reduction%=0
4440 reduction%=initialx%/2
4450 reduction%=reduction%*6
4460 IF initialx%<20 THEN reduction%=reduction%/2
4470 initialx%=initialx%*22-reduction%
4480 FOR fi%=12 TO 48
4490 LINE X-3,Y+20-fi%,X+initialx%+8,Y+20-fi%
4500 NEXT
4510 COLOUR 0,0,0,0
4520 GCOL 0
4530 MOVE tx,ty
4540 PRINT msg$
4550 MOVE 0,0
4560 ENDIF
4570 ENDPROC
4580 DEFPROCcrgb(r%,g%,b%)
4590 COLOUR 0,r%,g%,b% : GCOL 0
4600 ENDPROC
4610 REM RETROLIB 2
4620 REM THIS IS "RETROLIB" library version for NOVEMBER 28 2016 @ 6:08am
4630 DEF PROCblast(x%,y%,chance%)
4640 LOCAL dv%,dh%,xc%
4650 PROCdotsize(1)
4660 REPEAT
4670 dv%=RND(chance%)
4680 dh%=RND(chance%)
4690 PROCdotsize(2)
4700 PROCdotrgb(x%+dh%,y%+dv%,255,RND(255),100)
4710 dv%=RND(chance%)
4720 dh%=RND(chance%)
4730 PROCdotrgb(x%-dh%,y%+dv%,255,RND(255),100)
4740 dv%=RND(chance%)
4750 dh%=RND(chance%)
4760 PROCdotrgb(x%+dh%,y%-dv%,255,RND(255),100)
4770 dv%=RND(chance%)
4780 dh%=RND(chance%)
4790 PROCdotrgb(x%-dh%,y%-dv%,255,RND(255),100)
4800 WAIT 1
4810 xc%+=1
4820 UNTIL xc%>20
4830 ENDPROC
4840 DEF PROC_button(H,V,BEGIN,SIZE,X,C,A,DI)
4850 PROCcolor("f","000,000,000")
4860 LOCAL R,G,B,P
4870 R=X
4880 G=C
4890 B=A
4900 P=SIZE-BEGIN
4910 P=P/2
4920 P=BEGIN+P
4930 FOR Y=P TO SIZE
4940 COLOUR 0,X,C,A :GCOL 0
4950 LINE H-Y,V-Y,H+Y,V-Y
4960 LINE H+Y,V-Y,H+Y,V+Y
4970 LINE H+Y,V+Y,H-Y,V+Y
4980 LINE H-Y,V+Y,H-Y,V-Y
4990 X=X-DI
5000 C=C-DI
5010 A=A-DI
5020 IF X<2 THEN X=2
5030 IF C<2 THEN C=2
5040 IF A<2 THEN A=2
5050 NEXT Y
5060 P=SIZE-BEGIN
5070 P=P/2
5080 P=BEGIN+P
5090 FOR Y=BEGIN TO P
5100 COLOUR 1,X,C,A :GCOL 1
5110 LINE H-Y,V-Y,H+Y,V-Y
5120 LINE H+Y,V-Y,H+Y,V+Y
5130 LINE H+Y,V+Y,H-Y,V+Y
5140 LINE H-Y,V+Y,H-Y,V-Y
5150 X=X+DI
5160 C=C+DI
5170 A=A+DI
5180 NEXT Y
5190 PROCpaint(H,V,FNnumstr(R)+" "+FNnumstr(G)+" "+FNnumstr(B))
5200 PROCresetrgb
5210 ENDPROC
5220 DEF PROC_block(H,V,SIZE,X,C,A,DI)
5230 LOCAL P,Y
5240 P=SIZE/2
5250 FOR Y=1 TO SIZE
5260 COLOUR 0,X,C,A:GCOL 0
5270 LINE H-Y,V-Y,H+Y,V-Y
5280 LINE H+Y,V-Y,H+Y,V+Y
5290 LINE H+Y,V+Y,H-Y,V+Y
5300 LINE H-Y,V+Y,H-Y,V-Y
5310 X=X-DI
5320 C=C-DI
5330 IF X<2 THEN X=2
5340 IF C<2 THEN C=2
5350 IF A<2 THEN A=2
5360 P=P-1
5370 NEXT Y
5380 ENDPROC
5390 DEF PROC_donut(H,V,RR,GG,BB)
5400 PROC_ellipsering(3,3,H,V,30,40,RR,GG,BB,10)
5410 PROC_sphere(H,V,10,RR,GG,BB,7)
5420 ENDPROC
5430 DEF PROC_ellipsering(CENTERH,CENTERV,H,V,SIZE,THICKNESS,X,C,A,DI)
5440 IF SIZE > THICKNESS THEN SIZE = THICKNESS
5450 OC=THICKNESS/2
5460 OUTCENTERH=CENTERH+OC
5470 OUTCENTERV=CENTERV+OC
5480 R=0
5490 DEPTHCOUNT=SIZE/2
5500 FOR Y=1 TO DEPTHCOUNT
5510 COLOUR 1,X,C,A GCOL 1
5520 ELLIPSE H,V,OUTCENTERH-R,OUTCENTERV-R
5530 ELLIPSE H,V,OUTCENTERH+R,OUTCENTERV+R
5540 R=R+1
5550 X=X-DI
5560 C=C-DI
5570 A=A-DI
5580 IF X<2 THEN X=2
5590 IF C<2 THEN C=2
5600 IF A<2 THEN A=2
5610 NEXT Y
5620 PROCresetrgb
5630 ENDPROC
5640 REM ellipse h,v,sizex,sizey,R,G,B,dimmer
5650 DEF PROCellipse(h,v,sizex,sizey,x,c,a,di):REM' dimmer cannot be more than 24
5660 LOCAL limit,y,hi,wi
5670 MOVE h,v
5680 IF sizex>sizey THEN limit=sizex
5690 IF sizey>sizex THEN limit=sizey
5700 FOR y=0 TO limit
5710 PROCcrgb(x,c,a)
5720 hi=hi+1:IF sizex>sizey THEN hi=hi+1
5730 wi=wi+1:IF sizey>sizex THEN wi=wi+1
5740 IF hi>sizex THEN hi=sizex
5750 IF wi>sizey THEN wi=sizey
5760 ELLIPSE h,v,hi,wi
5770 x=x-di
5780 c=c-di
5790 a=a-di
5800 IF x<2 THEN x=2
5810 IF c<2 THEN c=2
5820 IF a<2 THEN a=2
5830 NEXT y
5840 ENDPROC
5850 DEFPROC_sphere(H,V,SIZE,R,G,B,DI)
5860 LOCAL r%,g%,b%,di%,x%,size%,skip%
5870 skip%=FALSE
5880 r%=R
5890 g%=G
5900 b%=B
5910 size%=SIZE
5920 di%=DI
5930 FOR x%=0 TO size%
5940 r%=r%-di%
5950 g%=g%-di%
5960 b%=b%-di%
5970 IF r% <2 THEN r%=2
5980 IF g% <2 THEN g%=2
5990 IF b%<2 THEN b%=2
6000 IF r%<50 AND g%<50 AND b%<50 THEN skip%=TRUE
6010 IF skip%=FALSE THEN
6020 COLOUR 1,r%,g%,b%:GCOL 1
6030 CIRCLE H,V,x%
6040 ENDIF
6050 NEXT x%
6060 PROCresetrgb
6070 ENDPROC
6080 DEFPROCdotsize(n)
6090 VDU 23,23,n|
6100 ENDPROC
6110 REM "mygraphics" - "INTERFACE" - "OBJECTS" - (Combined libraries) * to make it easier to manage
6120 REM save as "RETROLIB"
6130 REM To make this easier to modify, keep the remarks
6140 REM "OBJECTS" library
6150
6160 DEFPROCrighteye(x,y,location$,speed): PRIVATE dx,dy,counx,couny,eyeh,eyev,seyeh,seyev
6170 DEFPROClefteye(x,y,location$,speed) : PRIVATE dx,dy,counx,couny,eyeh,eyev,seyeh,seyev
6180 IF counx<x-12 THEN counx=x-12:REM this ensures the pupil stays within eye
6190 IF counx>x+12 THEN counx=x+12
6200 IF couny<y-12 THEN couny=y-12
6210 IF couny>y+12 THEN couny=y+12
6220 CASE location$ OF
6230 WHEN "center":dx=x:dy=y:eyeh=15:eyev=15
6240 WHEN "right":dx=x+80:dy=y:eyeh=10:eyev=15
6250 WHEN "down":dx=x:dy=y-80:eyev=10:eyeh=15
6260 WHEN "up":dx=x:dy=y+80:eyev=10:eyeh=15
6270 WHEN "left":dx=x-80:dy=y:eyeh=10:eyev=15
6280 ENDCASE
6290 IF counx<dx THEN counx=counx+1
6300 IF counx>dx THEN counx=counx-1
6310 IF couny<dy THEN couny=couny+1
6320 IF couny>dy THEN couny=couny-1
6330 IF seyeh<eyeh THEN seyeh+=.4
6340 IF seyeh>eyeh THEN seyeh-=.4
6350 IF seyev<eyev THEN seyev+=.4
6360 IF seyev>eyev THEN seyev-=.4
6370 REM dx, dy is meant to hold the destination of the pupil
6380 REM counx,couny is meant to hold the current pupil location
6390 REM eyeh,eyev is meant to hold the shape of the pupil as it moves
6400 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
6410 GCOL 15
6420 CIRCLE FILL x,y,20
6430 GCOL 4
6440 ELLIPSE FILL counx,couny,seyeh,seyev
6450 PROCcolor("f","000,000,000")
6460 ELLIPSE FILL counx,couny,seyeh/2,seyev/2
6470 WAIT speed
6480 ENDPROC
6490
6500
6510 REM COLORMIX object mixer
6520 DEFFNcolormix(x,y)
6530 PRIVATE rgb$,r%,g%,b%,switch%
6540 LOCAL h%,v%,click%
6550 MOUSE h%,v%,click%
6560 IF click%=4 THEN
6570 IF h%>x AND h%<x+50 AND v%>y AND v%<y+255 THEN r%=v%-y
6580 IF h%>x+49 AND h%<x+90 AND v%>y AND v%<y+255 THEN g%=v%-y
6590 IF h%>x+99 AND h%<x+140 AND v%>y AND v%<y+255 THEN b%=v%-y
6600 ENDIF
6610 IF switch%=0 OR click%=4 THEN
6620 PROCsbox(x-5,y-5,x+150,y+265,"255,255,255")
6630 PROCsbox(x,y+r%,x+40,y+r%+10,"200,000,000")
6640 PROCsbox(x+50,y+g%,x+90,y+g%+10,"000,200,000")
6650 PROCsbox(x+100,y+b%,x+140,y+b%+10,"000,000,200")
6660 switch%=1
6670 rgb$=FNnumstr(r%)+","+FNnumstr(g%)+","+FNnumstr(b%)
6680 PROCsbox(x-5,y+265,x+150,y+295,rgb$)
6690 ENDIF
6700 =rgb$
6710 REM GRAPHICS(x,y)
6720 DEF PROCgraphics(x,y)
6730 VDU 23,22,x;y;8,15,16,1
6740 OFF
6750 VDU 5
6760 REM these variables are temporary
6770 N%=0
6780 N%=20
6790 DIM X(20),Y(20),H(20),V(20)
6800 ENDPROC
6810 DEFFNkey
6820 response$=INKEY$(0)
6830 =response$
6840 REM SBOX **********************
6850 DEF PROCsbox(x%,y%,w%,h%,c$)
6860 LOCAL ry%,sx%,sy%
6870 sx%=x%:sy%=y%
6880 IF x%>w% THEN x%=w%:w%=sx%
6890 IF y%>h% THEN y%=h%:h%=sy%
6900 ry%=y%
6910 PROCcolor("f",c$)
6920 REPEAT
6930 LINE x%,y%,w%,y%
6940 y%=y%+1
6950 UNTIL y%=h%
6960 y%=ry%
6970 IF c$<>"0" THEN PROCcolor("f","000,000,000") ELSE PROCcolor("f","white")
6980 LINE x%+2,y%+2,w%-2,y%+2
6990 LINE w%-2,y%+2,w%-2,h%-4
7000 LINE w%-2,h%-4,x%+2,h%-4
7010 LINE x%+2,h%-4,x%+2,y%+2
7020 PROCresetrgb
7030 ENDPROC
7040 REM RECT **********************
7050 DEFPROCrect(x%,y%,w%,h%)
7060 LOCAL sx%,sy%
7070 sx%=x%:sy%=y%
7080 IF x%>w% THEN x%=w%:w%=sx%
7090 IF y%>h% THEN y%=h%:h%=sy%
7100 LINE x%,y%,w%,y%
7110 LINE w%,y%,w%,h%
7120 LINE w%,h%,x%,h%
7130 LINE x%,h%,x%,y%
7140 ENDPROC
7150 REM pixel *******************
7160 DEFPROCpixel(x%,y%,c$)
7170 PROCcolor("f",c$)
7180 MOVE x%,y%:DRAW x%,y%
7190 ENDPROC
7200 REM SET c$ can be colors like blue or 1 or a R,G,B color
7210 DEF PROCset(x%,y%,c$)
7220 LOCAL h%
7230 PROCcolor("f",c$)
7240 FOR h%=0 TO 20
7250 LINE x%+h%,y%,x%+h%,y%+20
7260 NEXT
7270 MOVE 0,0
7280 ENDPROC
7290 REM restore default color palettes
7300 DEFPROCresetrgb
7310 COLOUR 0,0,0,0 :COLOUR 1,200,0,0 :COLOUR 2,000,200,000
7320 COLOUR 3,200,200,000:COLOUR 4,000,000,200:COLOUR 5,200,000,200
7330 COLOUR 6,000,200,200:COLOUR 7,200,200,200:COLOUR 8,056,056,056
7340 COLOUR 9,248,056,056:COLOUR 10,056,248,056:COLOUR 11,248,248,056
7350 COLOUR 12,056,056,248:COLOUR 13,248,056,248:COLOUR 14,056,248,248
7360 COLOUR 15,248,248,248
7370 ENDPROC
7380 DEF PROCcolor(fb$,rgb$)
7390 PRIVATE assemble$,br%,bg%,bb%
7400 IF rgb$="0" OR rgb$="black" THEN rgb$="000,000,000"
7410 IF rgb$="1" OR rgb$="red" THEN rgb$="200,000,000"
7420 IF rgb$="2" OR rgb$="green" THEN rgb$="000,200,000"
7430 IF rgb$="3" OR rgb$="yellow" THEN rgb$="200,200,000"
7440 IF rgb$="4" OR rgb$="blue" THEN rgb$="000,000,200"
7450 IF rgb$="5" OR rgb$="magenta" THEN rgb$="200,000,200"
7460 IF rgb$="6" OR rgb$="cyan" THEN rgb$="000,200,200"
7470 IF rgb$="7" OR rgb$="white" THEN rgb$="200,200,200"
7480 IF rgb$="8" OR rgb$="grey" THEN rgb$="056,056,056"
7490 IF rgb$="9" OR rgb$="light red" THEN rgb$="248,056,056"
7500 IF rgb$="10" OR rgb$="light green" THEN rgb$="056,248,056"
7510 IF rgb$="11" OR rgb$="light yellow" THEN rgb$="248,248,056"
7520 IF rgb$="12" OR rgb$="light blue" THEN rgb$="056,056,248"
7530 IF rgb$="13" OR rgb$="light magenta" THEN rgb$="248,056,248"
7540 IF rgb$="14" OR rgb$="light cyan" THEN rgb$="056,248,248"
7550 IF rgb$="15" OR rgb$="light white" THEN rgb$="248,248,248"
7560 assemble$=rgb$
7570 br%=VAL(MID$(assemble$,1,3)):bg%=VAL(MID$(assemble$,5,3)):bb%=VAL(MID$(assemble$,9,3))
7580 IF fb$="f" OR fb$="F" THEN COLOUR 0,br%,bg%,bb% : GCOL 0
7590 IF fb$="b" OR fb$="B" THEN COLOUR 1,br%,bg%,bb% : GCOL 128+1
7600 ENDPROC
7610 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)
7620 DEFPROCmask(x%,y%,h%,v%)
7630 LOCAL dx%,dy%,c%,counx%,couny%
7640 counx%=0:couny%=0
7650 dx%= h%-x%
7660 dy%= v%-y%
7670 IF dx%>dy% THEN
7680 REPEAT
7690 c%=TINT(x%+counx%,y%+couny%)
7700 IF c%=0 THEN PROCpixel(x%+counx%,y%+couny%+dy%+1,"light white") ELSE PROCpixel(x%+counx%,y%+couny%+dy%+1,"0")
7710 couny%+=1:IF couny%=y%+dy% THEN couny%=0:counx%=counx%+1
7720 UNTIL counx%=dx%
7730 ENDIF
7740 IF dy%>dx% THEN
7750 REPEAT
7760 c%=TINT(x%+counx%,y%+couny%)
7770 IF c%=0 THEN PROCpixel(x%+counx%,y%+couny%+dy%+1,"255,255,255") ELSE PROCpixel(x%+counx%,y%+couny%+dy%+1,"0")
7780 counx%+=1:IF counx%=x%+dx% THEN counx%=0:couny%=couny%+1
7790 UNTIL couny%=dy%
7800 ENDIF
7810 ENDPROC
7820 DEFPROCgo(cm$,coun%)
7830 REM Simplified. Line draws the right color and right length now. Much faster. Zaphod
7840 PRIVATE x%,y%,pen%,c$
7850 REM x% ,y% are already in @vdu.p.x%, @vdu.p.y% so are not needed to be kept separately as PRIVATE variables
7860 REM @vdu.g.x has all the color details. BB4W Help "System Variables"
7870 LOCAL xinc%,yinc%,dist%
7880 CASE cm$ OF
7890 WHEN "up" : pen%=1
7900 WHEN "down" : pen%=0
7910 WHEN "fill" : PROCpaint(x%,y%,STR$(coun%))
7920 WHEN "c" : c$=STR$(coun%):PROCcolor("f",c$)
7930 ENDCASE
7940 dist%=INT(coun%/SQR(2)+0.5) REM round to the nearest pixel for 45° angles
7950 CASE cm$ OF
7960 WHEN "n" : yinc%=coun% : xinc%=0
7970 WHEN "s" : yinc%=-coun% : xinc%=0
7980 WHEN "e" : yinc%=0 : xinc%=coun%
7990 WHEN "w" : yinc%=0 : xinc%=-coun%
8000 WHEN "ne" :yinc%=dist% : xinc%=dist%
8010 WHEN "nw" :yinc%=dist% : xinc%=-dist%
8020 WHEN "sw" :yinc%=-dist% : xinc%=-dist%
8030 WHEN "se" :yinc%=-dist% : xinc%=dist%
8040 ENDCASE
8050 IF pen% =0 IF (ABS(yinc%)+ABS(xinc%))<>0 THEN LINE x%,y%,x%+xinc%,y%+yinc%
8060 x%+=xinc%:y%+=yinc%
8070 ENDPROC
8080 DEFFNnumstr(num)
8090 LOCAL cov$,l%
8100 cov$=STR$(num)
8110 l%=LEN(cov$)
8120 IF l%=1 THEN ret$="00"+cov$
8130 IF l%=2 THEN ret$="0"+cov$
8140 IF l%=3 THEN ret$=cov$
8150 =ret$
8160 DEFPROCpaint(x%,y%,co$)
8170 PROCcolor("b",FNrgb(x%,y%)):PROCcolor("f",co$)
8180 FILL x%,y%
8190 ENDPROC
8200 REM dotrgb ********************************
8210 DEFPROCdotrgb(x%,y%,r%,g%,b%)
8220 COLOUR 0,r%,g%,b% : GCOL 0
8230 MOVE x%,y%:DRAW x%,y%
8240 ENDPROC
8250 REM *****SPECIAL RGB tools (color extraction) has use with PROCdotrgb
8260 DEF PROCrgbret(x%,y%,RETURN r%,RETURN g%,RETURN b%)
8270 LOCAL rgb%
8280 rgb%=TINT(x%,y%)
8290 r%=rgb% AND &FF
8300 g%=rgb%>>8 AND &FF
8310 b%=rgb%>>16 AND &FF
8320 ENDPROC
8330
8340 REM experimental
8350 DEFFNrgb(x%,y%)
8360 LOCAL rgb%, r&, g&, b&
8370 rgb%=TINT(x%,y%)
8380 r&=rgb% :REM Use byte variable as mask.
8390 g&=rgb% >>8
8400 b&=rgb% >>16
8410 =FNnumstr(r&)+","+FNnumstr(g&)+","+FNnumstr(b&)
8420 REM getpic sorta functions like GET from the 80s but in this case it just assigns capture area information
8430 REM each getpic only needs to be called once, but you can reassign
8440 REM num refers to the variable arrays that will carry each image's capture point (it ranges from 0- 20)
8450 REM I guess h,v are the height and width of the image.
8460 DEFPROCgetpic(num%,xx,yy,hh,vv)
8470 N%=num%
8480 X(N%)=xx
8490 Y(N%)=yy
8500 H(N%)=hh
8510 V(N%)=vv
8520 ENDPROC
8530 REM Hmmm
8540 REM now that the image coordinates are stored, we can move it and redefine the borders
8550 DEFPROCpastepic(num%,nx,ny)
8560 LOCAL tx%,ty%,th%,tv%
8570 N%=num%
8580 tx%=X(N%)
8590 ty%=Y(N%)
8600 th%=H(N%)
8610 tv%=V(N%)
8620 RECTANGLE tx%,ty%,th%,tv% TO nx,ny
8630 X(N%)=nx
8640 Y(N%)=ny
8650 ENDPROC
8660 REM seems to work the same?
8670 DEFPROCmovepic(num,nx,ny)
8680 LOCAL tx%,ty%
8690 tx%=X(N%)
8700 ty%=Y(N%)
8710 RECTANGLE SWAP tx%,ty%,H(num),V(num) TO nx,ny
8720 X(N%)=nx
8730 Y(N%)=ny
8740 ENDPROC
8750 REM "INTERFACE" -library - for graphics text input and other tools
8760 REM X,Y,message,r,g,b
8770 DEF PROCpr(X,Y,msg$,c$)
8780 PRIVATE trackx,tracky,trackmsg$,trackc$
8790 LOCAL initialx%,fi%,reduction%,tx,ty
8800 IF trackx=X AND tracky=Y AND trackmsg$<>msg$ THEN PROCprsub(trackx,tracky,trackmsg$,"000,000,000")
8810 IF trackx<>X OR tracky<>Y OR trackmsg$<>msg$ OR trackc$<>c$ THEN
8820 initialx%=LEN(msg$)
8830 PROCcolor("f",c$)
8840 GCOL 0
8850 LET tx= X+initialx%+25
8860 LET ty= Y:reduction%=0
8870 reduction%=initialx%/2
8880 reduction%=reduction%*6
8890 IF initialx%<20 THEN reduction%=reduction%/2
8900 initialx%=initialx%*22-reduction%
8910 FOR fi%=12 TO 48
8920 LINE X-3,Y+20-fi%,X+initialx%+8,Y+20-fi%
8930 NEXT
8940 COLOUR 0,0,0,0
8950 GCOL 0
8960 MOVE tx,ty
8970 PRINT msg$
8980 MOVE 0,0
8990 ENDIF
9000 trackx=X:tracky=Y:trackmsg$=msg$:trackc$=c$
9010 ENDPROC
9020 REM used by PROCpr to enhance clean up from text overlays
9030 DEFPROCprsub(X,Y,msg$,c$)
9040 LOCAL initialx%,fi%,reduction%,tx,ty
9050 initialx%=LEN(msg$)
9060 PROCcolor("f",c$)
9070 GCOL 0
9080 LET tx= X+initialx%+25
9090 LET ty= Y:reduction%=0
9100 reduction%=initialx%/2
9110 reduction%=reduction%*6
9120 IF initialx%<20 THEN reduction%=reduction%/2
9130 initialx%=initialx%*22-reduction%
9140 FOR fi%=12 TO 48
9150 LINE X-3,Y+20-fi%,X+initialx%+8,Y+20-fi%
9160 NEXT
9170 COLOUR 0,0,0,0
9180 GCOL 0
9190 MOVE tx,ty
9200 PRINT msg$
9210 MOVE 0,0
9220 ENDPROC
9230 REM H,V,TEXTLIMIT (simpler?)
9240 DEF FNinput(bx,by,textlimit)
9250 LOCAL fill,MESSAGE$
9260 initialx%=0:sl%=0:key$="":MESSAGE$="":MES$=""
9270 initialx%=textlimit*16.2
9280 FOR fill=1 TO 58
9290 PROCcolor("f","15"):LINE bx+3,by+20-fill,bx+initialx%,by+20-fill
9300 NEXT fill
9310 PROCcolor("f","0"):LINE bx+3,by+20,bx+initialx%,by+20:LINE bx+3,by+20-fill,bx+initialx%,by+20-fill:
9320 REPEAT
9330 REPEAT
9340 key$ =INKEY$(1)
9350 PROCcolor("F","0")
9360 MOVE bx,by:PRINT MESSAGE$;"_" :* REFRESH
9370 sl%=LEN(MESSAGE$)
9380 UNTIL key$ <>""
9390 sl%=LEN(MESSAGE$)
9400 IF INKEY(-48) sl%=LEN(MESSAGE$)-1:key$=""
9410 REPEAT UNTIL INKEY(0)=-1
9420 IF sl%<LEN(MESSAGE$) THEN
9430 PROCcolor("F","15")
9440 MOVE bx,by
9450 PRINT MESSAGE$;"_"
9460 ENDIF
9470 MES$=MID$(MESSAGE$,0,sl%)
9480 MESSAGE$=MES$
9490 PROCcolor("F","15"):MOVE bx,by:PRINT MESSAGE$;"_"
9500 IF LEN(key$) = 1 THEN
9510 IF LEN(MESSAGE$)<textlimit THEN PROCcolor("F","15"):MOVE bx,by:PRINT MESSAGE$;"_": MESSAGE$=MESSAGE$+key$:* REFRESH OFF
9520 REM (jump)
9530 ENDIF
9540 UNTIL INKEY(-74)
9550 * REFRESH ON
9560 =MESSAGE$
9570 DEFFNbuttonz(X,Y,msg$)
9580 LOCAL initialx%,fi%,reduction%,tx,ty,mx%,my%,mb%,ad%,ady%,c$
9590 PRIVATE st$
9600 IF msg$<> "clearitall" THEN
9610 initialx%=LEN(msg$)
9620 LET tx= X+initialx%+25
9630 LET ty= Y:reduction%=0
9640 reduction%=initialx%/2
9650 reduction%=reduction%*6
9660 IF initialx%<20 THEN reduction%=reduction%/2
9670 initialx%=initialx%*22-reduction%
9680 MOUSE mx%,my%,mb%
9690 ad%=initialx%+8:ad%+=X:ady%=Y-28
9700 IF mx% >X AND mx%<ad% AND my%<Y+8 AND my%>ady% THEN
9710 c$="100,180,255"
9720 IF mb%=4 THEN st$=msg$
9730 ELSE c$="200,200,200"
9740 ENDIF
9750 IF FNrgb(X,Y)="000,000,000" THEN c$="200,200,200"
9760 PROCcolor("f",c$)
9770 IF FNrgb(X,Y)<>c$ THEN
9780 FOR fi%=12 TO 48
9790 LINE X-3,Y+20-fi%,X+initialx%+8,Y+20-fi%
9800 NEXT
9810 PROCcolor("f","000,000,000")
9820 MOVE tx,ty
9830 PRINT msg$
9840 ENDIF
9850 ENDIF
9860 IF msg$="clearitall" THEN st$=""
9870 MOVE 0,0 REM hide that thing
9880 =st$
9890 DEFFNstcorecol(wdnum$)
9900 PROCresetrgb
9910 LOCAL tcol%
9920 CASE wdnum$ OF
9930 WHEN "0","black" :tcol%=0
9940 WHEN "1","red" :tcol%=1
9950 WHEN "2","green" :tcol%=2
9960 WHEN "3","yellow" :tcol%=3
9970 WHEN "4","blue" :tcol%=4
9980 WHEN "5","magneta" :tcol%=5
9990 WHEN "6","cyan":tcol%=6
10000 WHEN "7","white":tcol%=7
10010 WHEN "8","grey":tcol%=8
10020 WHEN "9","light red":tcol%=9
10030 WHEN "10","light green":tcol%=10
10040 WHEN "11","light yellow":tcol%=11
10050 WHEN "12","light blue":tcol%=12
10060 WHEN "13","light magneta":tcol%=13
10070 WHEN "14","light cyan":tcol%=14
10080 WHEN "15","light white" :tcol%=15
10090 ENDCASE
10100 =tcol%
10110 DEF PROCfcolor(co$)
10120 LOCAL rcol%
10130 rcol%=FNstcorecol(co$)
10140 GCOL rcol%
10150 ENDPROC
10160 DEF PROCbcolor(co$)
10170 LOCAL rcol%
10180 rcol%=FNstcorecol(co$)
10190 GCOL 128 +rcol%
10200 ENDPROC