Some RISC OS graphical ditties converted to BB4W
Post by David Williams on Nov 8th, 2015, 10:51am
These are from Jan Vibe (many old-timer RISC OS users will remember this guy). I think I might have put these up before, but looking back through this section of the forum, I can't find them. So perhaps I didn't?
Jan Vibe's 'Guts' (both versions are full screen; click mouse or press Escape to exit):
Code:
REM > GUTS
REM Original ARM BBC BASIC version by Jan Vibe
REM Adapted for BB4W by DW
*FLOAT 64
ON CLOSE VDU 7 : QUIT
ON ERROR PROC_error
GWL_STYLE = -16
HWND_TOPMOST = -1
WS_VISIBLE = &10000000
WS_CLIPCHILDREN = &2000000
WS_CLIPSIBLINGS = &4000000
SYS "GetSystemMetrics", 0 TO xscreen%
SYS "GetSystemMetrics", 1 TO yscreen%
SYS "SetWindowLong", @hwnd%, GWL_STYLE, WS_VISIBLE + \
\ WS_CLIPCHILDREN + WS_CLIPSIBLINGS
SYS "SetWindowPos", @hwnd%, HWND_TOPMOST, 0, 0, xscreen%, yscreen%, 0
VDU 26 : OFF
GCOL 0 : FILL 0,0
scrW% = @vdu%!208
scrH% = @vdu%!212
DIM BX%(15),by%(15),BZ(15):BX%()=-100:A%=0
FORN%=1TO15:COLOUR 16-N%,7*N%+150,14*N%+45,14*N%+45:NEXT
X1%=RND(scrW%)+256:Y1%=RND(scrH%)+256
DX1%=RND(16)*SGN(RND(1)-.5):DY1%=RND(16)*SGN(RND(1)-.5)
X2%=RND(scrW%)+256:Y2%=RND(scrH%)+256
DX2%=RND(16)*SGN(RND(1)-.5):DY2%=RND(16)*SGN(RND(1)-.5)
REPEAT
MOUSE msX%, msY%, mBtn%
H%=X1%+DX1%:IF H%<256 OR H%>2*scrW%-256 DX1%=RND(16)*SGN(-DX1%)
H%=Y1%+DY1%:IF H%<256 OR H%>scrH%+512 DY1%=RND(16)*SGN(-DY1%)
X1%+=DX1%:Y1%+=DY1%
IF X2%<X1% AND DX2%<24 DX2%+=1
IF X2%>X1% AND DX2%>-24 DX2%-=1
IF Y2%<Y1% AND DY2%<24 DY2%+=1
IF Y2%>Y1% AND DY2%>-24 DY2%-=1
X2%+=DX2%:Y2%+=DY2%:A%=(A%+10)MOD360:Z=(SINRADA%+1)+2
FORN%=2TO15
BX%(N%-1)=BX%(N%):by%(N%-1)=by%(N%):BZ(N%-1)=BZ(N%)
NEXT:BX%(15)=X2%:by%(15)=Y2%:BZ(15)=Z
FORN%=1TO15:GCOLN%:CIRCLE FILL BX%(N%),by%(N%),N%*BZ(N%):NEXT
UNTIL mBtn% <> 0
VDU 7 : QUIT
END
DEF PROC_fixWindowSize
LOCAL GWL_STYLE, WS_THICKFRAME, WS_MAXIMIZEBOX, ws%
GWL_STYLE = -16
WS_THICKFRAME = &40000
WS_MAXIMIZEBOX = &10000
SYS "GetWindowLong", @hwnd%, GWL_STYLE TO ws%
SYS "SetWindowLong", @hwnd%, GWL_STYLE, ws% AND NOT (WS_THICKFRAME+WS_MAXIMIZEBOX)
ENDPROC
DEF PROC_error
IF ERR = 17 THEN VDU 7 : QUIT
OSCLI "REFRESH ON" : ON
COLOUR 0, 0, 0, 0
COLOUR 128, 0, 0, 0 : COLOUR 128
COLOUR 7, 255, 255, 255 : COLOUR 7
VDU 7
REPORT : PRINT " at line "; ERL;
REPEAT : WAIT 1 : UNTIL FALSE
ENDPROC
Code:
REM > GUTS2
REM Original ARM BBC BASIC version by Jan Vibe
REM Adapted for BB4W by DW
*FLOAT 64
ON CLOSE VDU 7 : QUIT
ON ERROR PROC_error
GWL_STYLE = -16
HWND_TOPMOST = -1
WS_VISIBLE = &10000000
WS_CLIPCHILDREN = &2000000
WS_CLIPSIBLINGS = &4000000
SYS "GetSystemMetrics", 0 TO xscreen%
SYS "GetSystemMetrics", 1 TO yscreen%
SYS "SetWindowLong", @hwnd%, GWL_STYLE, WS_VISIBLE + \
\ WS_CLIPCHILDREN + WS_CLIPSIBLINGS
SYS "SetWindowPos", @hwnd%, HWND_TOPMOST, 0, 0, xscreen%, yscreen%, 0
VDU 26 : OFF
GCOL 0 : FILL 0,0
scrW% = @vdu%!208
scrH% = @vdu%!212
DIM BX%(15),by%(15),BZ(15),R(15),G(15),B(15)
BX%()=-100:A%=0:AR%=RND(360):AG%=RND(360):AB%=RND(360)
REMSYS "OS_SWINumberFromString",,"ColourTrans_SetGCOL" TO set_gcol%
X1%=RND(scrW%)+256:Y1%=RND(scrH%)+256
DX1%=RND(16)*SGN(RND(1)-.5):DY1%=RND(16)*SGN(RND(1)-.5)
X2%=RND(scrW%)+256:Y2%=RND(scrH%)+256
DX2%=RND(16)*SGN(RND(1)-.5):DY2%=RND(16)*SGN(RND(1)-.5)
GCOL 1
REPEAT
MOUSE msX%, msY%, msBtn%
H%=X1%+DX1%:IF H%<256 OR H%>2*scrW%-256 DX1%=RND(16)*SGN(-DX1%)
H%=Y1%+DY1%:IF H%<256 OR H%>scrH%+512 DY1%=RND(16)*SGN(-DY1%)
X1%+=DX1%:Y1%+=DY1%
IF X2%<X1% AND DX2%<24 DX2%+=1
IF X2%>X1% AND DX2%>-24 DX2%-=1
IF Y2%<Y1% AND DY2%<24 DY2%+=1
IF Y2%>Y1% AND DY2%>-24 DY2%-=1
X2%+=DX2%:Y2%+=DY2%:A%=(A%+10)MOD360:Z=(SINRADA%+1)+2
AR%=(AR%+RND(12))MOD360:SR=(1+SINRADAR%)/2
AG%=(AG%+RND(12))MOD360:SG=(1+SINRADAG%)/2
AB%=(AB%+RND(12))MOD360:SB=(1+SINRADAB%)/2
FORN%=2TO15
BX%(N%-1)=BX%(N%):by%(N%-1)=by%(N%):BZ(N%-1)=BZ(N%)
R(N%-1)=R(N%):G(N%-1)=G(N%):B(N%-1)=B(N%)
NEXT
BX%(15)=X2%:by%(15)=Y2%:BZ(15)=Z:R(15)=SR:G(15)=SG:B(15)=SB
FORN%=1TO15
CR=1-N%/15*R(N%):CG=1-N%/15*G(N%):CB=1-N%/15*B(N%)
REMSYS set_gcol%,((CR*&FF)<<8)+((CG*&FF)<<16)+((CB*&FF)<<24),,,&100,0
COLOUR 1, 255*CR, 255*CG, 255*CB
CIRCLE FILL BX%(N%),by%(N%),N%*BZ(N%):NEXT
UNTIL msBtn% <> 0
VDU 7: QUIT
END
DEF PROC_fixWindowSize
LOCAL GWL_STYLE, WS_THICKFRAME, WS_MAXIMIZEBOX, ws%
GWL_STYLE = -16
WS_THICKFRAME = &40000
WS_MAXIMIZEBOX = &10000
SYS "GetWindowLong", @hwnd%, GWL_STYLE TO ws%
SYS "SetWindowLong", @hwnd%, GWL_STYLE, ws% AND NOT (WS_THICKFRAME+WS_MAXIMIZEBOX)
ENDPROC
DEF PROC_error
IF ERR = 17 THEN VDU 7 : QUIT
OSCLI "REFRESH ON" : ON
COLOUR 0, 0, 0, 0
COLOUR 128, 0, 0, 0 : COLOUR 128
COLOUR 7, 255, 255, 255 : COLOUR 7
VDU 7
REPORT : PRINT " at line "; ERL;
REPEAT : WAIT 1 : UNTIL FALSE
ENDPROC
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 8th, 2015, 10:53am
'ELASTIC2' by Jan Vibe (sorry if I've put this up before; I don't remember doing so!):
Code:
REM > ELASTIC2 *** Jan Vibe february 94 ***
REM Original ARM BBC BASIC version by Jan Vibe
REM Adapted (and modified) for BB4W by DW
*ESC OFF
ON ERROR PROC_error
PROC_fixWindowSize
MODE 8 : OFF
COLOUR0,0,0,255 : COLOUR 128 : CLS
PRINTTAB(33,1)"Elastic sheet"'
PRINTTAB(10)"This program demonstrates the movements of a elastic sheet."
PRINTTAB(10)"The sheet is made up of coloured rectangles, the corners of"
PRINTTAB(10)"which can be moved with the mousepointer."'
PRINTTAB(10)"To move a corner, place the pointer near the corner and"
PRINTTAB(10)"press the left mousebutton down, and hold it down. This"
PRINTTAB(10)"causes the corner nearest the pointer to lock onto the"
PRINTTAB(10)"pointer, and follow it when it is moved. When the mouse-"
PRINTTAB(10)"button is released, the corner is free to move again."'
PRINTTAB(10)"A corner can be stopped from moving by placing the pointer"
PRINTTAB(10)"over it, and pressing the right mousebutton. The corner"
PRINTTAB(10)"is now fixed, but can still be moved with the mouse."'
PRINTTAB(10)"The fixed corners can be released by moving the mouse over"
PRINTTAB(10)"the corner, and pressing the middle mousebutton."
PRINTTAB(23,25)"Click any mousebutton to continue"
REPEAT:MOUSE A%,B%,C%:UNTILC%<>0
REPEAT:MOUSE A%,B%,C%:UNTILC%=0
W%=16 :REM Number of points in X direction
H%=15 :REM Number of points in Y direction
WX%=1280 :REM Width of original sheet
HY%=1024 :REM Height of original sheet
V%=6 :REM Weight of sheet material
T=0.5 :REM Tendency of sheet corners to stay where put originally
D=0.99 :REM Damping factor
P1%=1:P2%=2:S1%=1:S2%=2:PX%=0:PY%=0:D1=0
WD=(1280-WX%)/2:WB=WX%/(W%-1):HD=(1024-HY%)/2:HB=HY%/(H%-1)
DIM X(W%,H%,2),Y(W%,H%,2),DX(W%,H%),DY(W%,H%),F%(W%,H%)
DIM OX(W%,H%),OY(W%,H%)
FORN%=1TO15:COLOURN%,16*N%,16*N%,0:NEXT
REM placing of balls
FORJ%=1TOH%:FORI%=1TOW%
X(I%,J%,P1%)=WD+(I%-1)*WB:Y(I%,J%,P1%)=HD+(J%-1)*HB
OX(I%,J%)=X(I%,J%,P1%):OY(I%,J%)=Y(I%,J%,P1%)
NEXT
NEXT
TIME=0
REM ONERRORGOTO890
REM*POINTER
*REFRESH OFF
REM Screen and mouse control
REPEAT
CLS
REMSYS 6,112,S1%:SYS 6,113,S2%:WAIT:CLS:SWAP S1%,S2%
GPX%=PX%:GPY%=PY%:PX%=0:PY%=0:MOUSE XM,YM,BM%
IF BM%<>0 THEN
DL=1E9:FORJ%=1TOH%:FORI%=1TOW%
DM=(X(I%,J%,P1%)-XM)^2+(Y(I%,J%,P1%)-YM)^2:IF DM<DL DL=DM:PX%=I%:PY%=J%
NEXT:NEXT:IF GPX%<>0 PX%=GPX%:PY%=GPY%
X(PX%,PY%,P1%)=XM:Y(PX%,PY%,P1%)=YM
IF BM%=1 F%(PX%,PY%)=1
IF BM%=2 F%(PX%,PY%)=0
ENDIF
IF TIME>300 D1=D
SWAP P1%,P2%
REM drawing of net
FORJ%=1TOH%-1:FORI%=1TOW%-1:C%=J%+I%:GCOLABS((C%MOD28)-14)+1
MOVEX(I%,J%,P2%),Y(I%,J%,P2%):MOVEX(I%+1,J%,P2%),Y(I%+1,J%,P2%)
PLOT85,X(I%,J%+1,P2%),Y(I%,J%+1,P2%)
PLOT85,X(I%+1,J%+1,P2%),Y(I%+1,J%+1,P2%)
NEXT
NEXT
REM Calculate new position for net
FORJ%=1TOH%:FORI%=1TOW%
IF NOT(I%=PX%ANDJ%=PY%) THEN
IF F%(I%,J%)=1 THEN
X(I%,J%,P1%)=X(I%,J%,P2%):Y(I%,J%,P1%)=Y(I%,J%,P2%)
ELSE
WT=0:NX=0:NY=0
IF I%>1 THEN NX+=X(I%-1,J%,P2%):NY+=Y(I%-1,J%,P2%):WT+=1
IF I%<W% THEN NX+=X(I%+1,J%,P2%):NY+=Y(I%+1,J%,P2%):WT+=1
IF J%>1 THEN NX+=X(I%,J%-1,P2%):NY+=Y(I%,J%-1,P2%):WT+=1
IF J%<H% THEN NX+=X(I%,J%+1,P2%):NY+=Y(I%,J%+1,P2%):WT+=1
NX+=OX(I%,J%)*T:NY+=OY(I%,J%)*T:WT+=T
NX+=X(I%,J%,P2%)*V%:NY+=Y(I%,J%,P2%)*V%:WT+=V%
X(I%,J%,P1%)=NX/WT+DX(I%,J%):Y(I%,J%,P1%)=NY/WT+DY(I%,J%)
DX(I%,J%)=(X(I%,J%,P1%)-X(I%,J%,P2%))*D1
DY(I%,J%)=(Y(I%,J%,P1%)-Y(I%,J%,P2%))*D1
ENDIF
ENDIF
NEXT
NEXT
*REFRESH
WAIT 1
UNTIL0
REMSYS 6,112,S1%:REPORT:PRINT" at line "STR$ERL:ON
DEF PROC_fixWindowSize
LOCAL GWL_STYLE, WS_THICKFRAME, WS_MAXIMIZEBOX, ws%
GWL_STYLE = -16
WS_THICKFRAME = &40000
WS_MAXIMIZEBOX = &10000
SYS "GetWindowLong", @hwnd%, GWL_STYLE TO ws%
SYS "SetWindowLong", @hwnd%, GWL_STYLE, ws% AND NOT (WS_THICKFRAME+WS_MAXIMIZEBOX)
ENDPROC
DEF PROC_error
OSCLI "REFRESH ON" : ON : COLOUR 7 : VDU 7
REPORT : PRINT " at line "; ERL;
REPEAT : WAIT 1 : UNTIL FALSE
ENDPROC
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 8th, 2015, 12:25pm
Jan Vibe's 'JELLY2' (use the mouse to nudge the jelly, but do it subtly!):
Code:
REM > JELLY2
REM by Jan Vibe
REM Adapted for BB4W by DW
MODE 8 : OFF
REMMODE224:MODE 96
DIM X(39,1),Y(39,1),DX(39),DY(39),OX(39),OY(39)
P1%=0:P2%=1:S1%=1:S2%=2:REM*POINTER
FORN%=0TO39:T=RAD(9*N%)
X(N%,0)=640+300*SINT:OX(N%)=X(N%,0)
Y(N%,0)=512+300*COST:OY(N%)=Y(N%,0)
NEXT
REMONERRORGOTO320
*REFRESH OFF
REPEAT
CLS
SWAP P1%,P2%
REMSYS 6,112,S1%:SYS 6,113,S2%:WAIT:CLS:SWAP S1%,S2%
MOVEX(39,P2%),Y(39,P2%)
@vdu%!248=2 : REM BB4W enhancement: thicker lines
FORN%=0TO39:DRAWX(N%,P2%),Y(N%,P2%):NEXT
@vdu%!248=1
FORN%=0TO39:N1%=(N%+1)MOD40:N2%=(N%+39)MOD40
OB%=B%:MOUSE X%,Y%,B%:IF B%<>0 THEN
IF B%<>OB% THEN
D=1E9:M%=0:FORI%=0TO39:Z=(X%-X(I%,P2%))^2+(Y%-Y(I%,P2%))^2
IF Z<D D=Z:M%=I%
NEXT
ENDIF
X(M%,P1%)=X%:Y(M%,P1%)=Y%
ENDIF
X(N%,P1%)=(3*X(N%,P2%)+X(N1%,P2%)+X(N2%,P2%)+OX(N%))/6+DX(N%)
Y(N%,P1%)=(3*Y(N%,P2%)+Y(N1%,P2%)+Y(N2%,P2%)+OY(N%))/6+DY(N%)
IF B%=0 OR N%<>M% THEN
DX(N%)=(X(N%,P1%)-X(N%,P2%))*.98:DY(N%)=(Y(N%,P1%)-Y(N%,P2%))*.98
ENDIF
NEXT
*REFRESH
WAIT 1
UNTIL0
REMSYS 6,112,S1%:REPORT:PRINT" at line "STR$ERL:ON
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 8th, 2015, 12:40pm
'COLTRAP2' by Jan Vibe:
Code:
REM > COLTRAP2
REM by Jan Vibe
REM Adapted for BB4W by DW
REMMODE"X1024 Y768 C32K":OFF
*ESC OFF
ON ERROR PROCError(REPORT$ + " at line " + STR$ERL)
ScrW% = 1024
ScrH% = 768
PROCFixWndSz
VDU 23,22,ScrW%;ScrH%;8,16,16,0 : VDU 26 : OFF
DIM P%(4,5)
GCOL 15
REPEAT
FOR N%=1TO4:FORM%=3TO5:P%(N%,M%)=RND(255):NEXT,
P%(1,1)=RND(1024):P%(1,2)=RND(768)
P%(2,1)=RND(1024)+1024:P%(2,2)=RND(768)
P%(3,1)=RND(1024)+1024:P%(3,2)=RND(768)+768
P%(4,1)=RND(1024):P%(4,2)=RND(768)+768
PROCCS(P%(),30)
UNTIL0
DEFPROCCS(P%(),D%)
LOCAL N%,M%,XA%(),YA%(),RA%(),GA%(),BA%(),X%(),Y%(),R%(),G%(),B%()
DIMXA%(2),YA%(2),RA%(2),GA%(2),BA%(2)
DIMX%(D%,D%),Y%(D%,D%),R%(D%,D%),G%(D%,D%),B%(D%,D%)
FORN%=0TOD%
XA%(1)=(P%(1,1)*(D%-N%)+P%(4,1)*N%)/D%
YA%(1)=(P%(1,2)*(D%-N%)+P%(4,2)*N%)/D%
RA%(1)=(P%(1,3)*(D%-N%)+P%(4,3)*N%)/D%
GA%(1)=(P%(1,4)*(D%-N%)+P%(4,4)*N%)/D%
BA%(1)=(P%(1,5)*(D%-N%)+P%(4,5)*N%)/D%
XA%(2)=(P%(2,1)*(D%-N%)+P%(3,1)*N%)/D%
YA%(2)=(P%(2,2)*(D%-N%)+P%(3,2)*N%)/D%
RA%(2)=(P%(2,3)*(D%-N%)+P%(3,3)*N%)/D%
GA%(2)=(P%(2,4)*(D%-N%)+P%(3,4)*N%)/D%
BA%(2)=(P%(2,5)*(D%-N%)+P%(3,5)*N%)/D%
FORM%=0TOD%
X%(M%,N%)=(XA%(1)*(D%-M%)+XA%(2)*M%)/D%
Y%(M%,N%)=(YA%(1)*(D%-M%)+YA%(2)*M%)/D%
R%(M%,N%)=(RA%(1)*(D%-M%)+RA%(2)*M%)/D%
G%(M%,N%)=(GA%(1)*(D%-M%)+GA%(2)*M%)/D%
B%(M%,N%)=(BA%(1)*(D%-M%)+BA%(2)*M%)/D%
NEXTM%,N%
FOR N%=0TOD%-1:FORM%=0TOD%-1
RA%(1)=(R%(M%,N%)+R%(M%+1,N%)+R%(M%+1,N%+1)+R%(M%,N%+1))/4
GA%(1)=(G%(M%,N%)+G%(M%+1,N%)+G%(M%+1,N%+1)+G%(M%,N%+1))/4
BA%(1)=(B%(M%,N%)+B%(M%+1,N%)+B%(M%+1,N%+1)+B%(M%,N%+1))/4
REMPROCRGB(RA%(1),GA%(1),BA%(1))
COLOUR 15, RA%(1), GA%(1), BA%(1)
MOVEX%(M%,N%),Y%(M%,N%):MOVEX%(M%+1,N%),Y%(M%+1,N%)
PLOT85,X%(M%,N%+1),Y%(M%,N%+1):PLOT85,X%(M%+1,N%+1),Y%(M%+1,N%+1)
NEXTM%,N%
ENDPROC
REM DEFPROCRGB(R%,G%,B%)
REM LOCAL C%:C%=(R%<<8)+(G%<<16)+(B%<<24)
REM SYS "ColourTrans_SetGCOL",C%,,,&100,0
REM ENDPROC
DEF PROCFixWndSz
LOCAL W%
SYS"GetWindowLong",@hwnd%,-16 TO W%
SYS"SetWindowLong",@hwnd%,-16,W% ANDNOT&40000 ANDNOT&10000
ENDPROC
DEF PROCError(s$)
OSCLI "REFRESH ON"
CLS : ON : VDU 7
PRINT '" " + s$;
REPEAT UNTIL INKEY(1)=0
ENDPROC
Re: Some RISC OS graphical ditties converted to BB
Post by dfeugey on Nov 8th, 2015, 3:28pm
Very interesting too. Could be good screensavers (with a few more code to integrate in windows as screensaver).
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 8th, 2015, 4:15pm
on Nov 8th, 2015, 3:28pm, dfeugey wrote:Very interesting too. Could be good screensavers (with a few more code to integrate in windows as screensaver).
|
|
Cheers, David. Just occupying myself on this most solemn of days. Here's another Vibe effort:
Jan Vibe's 'Facets' - two variants. The first version uses BB4W's native graphics commands (i.e. Windows GDI); the second version uses my graphics library (GLIB, not GFXLIB) to draw the circles.
Code:
REM > FACETS
REM by Jan Vibe
REM Adapted for BB4W by DW
REMMODE28:OFF
MODE 19 : OFF : REM 640x480
ScrW% = @vdu%!208
ScrH% = @vdu%!212
K%=1000:R%=40
DIM X%(K%),Y%(K%),C%(K%),LX%(10000),LY%(10000)
B%=0:REPEAT:T%=0:B%+=1
REPEAT:X%(B%)=RND(ScrW%):Y%(B%)=RND(ScrH%):C%(B%)=RND(63):T%+=1
UNTIL POINT(2*X%(B%),2*Y%(B%))=0 OR T%>=5000
GCOL C%(B%):CIRCLE FILL 2*X%(B%),2*Y%(B%),2*R%
UNTILT%>=5000
FORN%=R%TO0STEP-1
FORI%=1TOB%:GCOL C%(I%):CIRCLE FILL 2*X%(I%),2*Y%(I%),2*N%:NEXTI%,N%
LP%=0:GCOL0
FORY%=0TOScrH% STEP 2
FORX%=0TOScrW% STEP 2
C%=POINT(2*X%,2*Y%):F%=0
IFPOINT(2*X%-2,2*Y%)<>C% F%=1
IFPOINT(2*X%+2,2*Y%)<>C% F%=1
IFPOINT(2*X%,2*Y%-2)<>C% F%=1
IFPOINT(2*X%,2*Y%+2)<>C% F%=1
IFF%=1 LP%+=1:LX%(LP%)=X%:LY%(LP%)=Y%
NEXTX%,Y%
FORN%=1TOLP%
CIRCLE FILL 2*LX%(N%),2*LY%(N%),2*4
NEXT
The GLIB-based one can be downloaded from the following URL. The Zip folder includes the compiled EXE, and the source (including library files). This version loops every 10 seconds.
http://www.proggies.uk/bb4w/facets_glib.zip
David.
--
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 9th, 2015, 12:33pm
More Vibisms!
Code:
REM > CA2
REM by Jan Vibe
REM Adapted for BB4W by DW
REMMODE9:OFF
MODE 8 : OFF
DIMA%(10000),B%(10000)
F%=4:N%=2:A%()=640:B%()=512:GCOL1
FORN%=1TO8:COLOUR N%+7,31*N%,31*N%,240:NEXT:COLOUR0,0,0,128
REPEAT
P%=RND(N%):X%=A%(P%):Y%=B%(P%):A%(P%)=A%(N%):B%(P%)=B%(N%):N%-=1
A%=X%+F%:B%=X%-F%:C%=Y%+F%:D%=Y%-F%:CC%=0
FORI%=-8TO8STEP4:FORJ%=-8TO8STEP4
IF NOT(I%=0 AND J%=0) CC%-=(POINT(X%+I%,Y%+J%)<>0)
NEXT,:GCOL CC%/3+7:PLOT X%,Y%:GCOL1
PROCS(X%,C%):PROCS(B%,Y%):PROCS(X%,D%):PROCS(A%,Y%)
PROCS(B%,C%):PROCS(B%,D%):PROCS(A%,D%):PROCS(A%,C%)
UNTIL N%=-1
END
DEFPROCS(X%,Y%)
LOCAL A%,C%
IF POINT(X%,Y%)=0 THEN
FORA%=-24TO20STEP4
IF POINT(X%-24,Y%+A%)<>0 C%+=1
IF POINT(X%+24,Y%+A%+4)<>0 C%+=1
IF POINT(X%+A%+4,Y%-24)<>0 C%+=1
IF POINT(X%+A%,Y%+24)<>0 C%+=1
NEXT
IFC%<=15 N%+=1:A%(N%)=X%:B%(N%)=Y%:PLOT X%,Y%
ENDIF
ENDPROC
Code:
REM > CIRCLE2
REM by Jan Vibe
REM Very slightly modified by DW (space character inserted after DRAWBY),
REM but result still not quite correct (due, I think, to ARM BASIC and
REM BB4W handling the DRAW BY statement slightly differently).
REM Jan's comment:
REM
REM Inspired from Allister Jenks 'Cropcircle' in the september issue
REM of Acorn user. The flattened corn has been given the plaited look
REM the 'real' crop circles always have.
Code proceeds as the following one-liner:
Code:MODE8:OFF:R=350:L=640:M=512:FORN=1TO15:COLOURN,16*N,12*N,0:NEXT:COLOUR0,112,64,0:FORY=950TO0STEP-50:FORX=0TO1280STEP2:A=X+RND(32):B=Y+RND(50):Q=SQR((L-A)^2+(M-B)^2):Z=-(ABS(Q-R)<80):K=A-L:O=ACS(K/Q):V=PI+O*(B>M)-O*(B<=M):C=Z*4*SINV+(1-Z)*(4*RND(1)-2):D=Z*4*COSV+(1-Z)*4:MOVEA,B:FORN=1TO15:GCOLN:DRAWBY C,D:NEXT,,
Correct version (multi-line):
Code:
REM > CIRCLE2
REM by Jan Vibe
REM Adapted for BB4W by DW
REM Inspired from Allister Jenks 'Cropcircle' in the september issue
REM of Acorn user. The flattened corn has been given the plaited look
REM the 'real' crop circles always have.
MODE 8
OFF
R = 350
L = 640
M = 512
FOR N = 1 TO 15
COLOUR N,16*N,12*N,0
NEXT
COLOUR 128,112,64,0 : CLG
FOR Y = 950 TO 0 STEP -50
FOR X = 0 TO 1280 STEP 2
A = X + RND(32)
B = Y + RND(50)
Q = SQR((L-A)^2 + (M-B)^2)
Z = -(ABS(Q-R) < 80)
K = A-L
O = ACS(K/Q)
V = PI + O*(B>M)-O*(B<=M)
C = Z*4*SINV + (1-Z)*(4*RND(1)-2)
D = Z*4*COSV + (1-Z)*4
MOVE A, B
FOR N = 1 TO 15
GCOL N
DRAW A+N*C, B+N*D
NEXT N
NEXT X
NEXT Y
Code:
REM > COLSQUARE
REM by Jan Vibe
REM Adapted for BB4W by DW
MODE8:OFF
GCOL 15
F%=TIME:DIM C%(4,3),P%(10,8,3)
FORJ%=0TO8:FORI%=0TO10:FORN%=1TO3:P%(I%,J%,N%)=RND(255):NEXT,,
FORJ%=0TO7:FORI%=0TO9:FORN%=1TO3
C%(1,N%)=P%(I%,J%,N%)
C%(2,N%)=P%(I%+1,J%,N%)
C%(3,N%)=P%(I%+1,J%+1,N%)
C%(4,N%)=P%(I%,J%+1,N%)
NEXT
X1%=I%*128:Y1%=J%*128:X2%=X1%+128:Y2%=Y1%+128
PROCP(X1%,Y1%,C%(1,1),C%(1,2),C%(1,3))
PROCA(X1%,Y1%,X2%,Y2%,C%())
NEXT,
END
DEFPROCA(X1%,Y1%,X3%,Y3%,FC%())
LOCAL X2%,Y2%,N%,LC%(),MC%()
DIM LC%(4,3),MC%(5,3)
X2%=(X1%+X3%)/2:Y2%=(Y1%+Y3%)/2
FORN%=1TO3
MC%(1,N%)=(FC%(1,N%)+FC%(2,N%))/2
MC%(2,N%)=(FC%(2,N%)+FC%(3,N%))/2
MC%(3,N%)=(FC%(3,N%)+FC%(4,N%))/2
MC%(4,N%)=(FC%(4,N%)+FC%(1,N%))/2
NEXT
FORN%=1TO3:MC%(5,N%)=(MC%(1,N%)+MC%(2,N%)+MC%(3,N%)+MC%(4,N%))/4:NEXT
PROCP(X2%,Y1%,MC%(1,1),MC%(1,2),MC%(1,3))
PROCP(X1%,Y2%,MC%(4,1),MC%(4,2),MC%(4,3))
PROCP(X2%,Y2%,MC%(5,1),MC%(5,2),MC%(5,3))
IF X2%-X1%>8 OR Y2%-Y1%=8 THEN
FORN%=1TO3:LC%(1,N%)=FC%(1,N%):LC%(2,N%)=MC%(1,N%)
LC%(3,N%)=MC%(5,N%):LC%(4,N%)=MC%(4,N%):NEXT
PROCA(X1%,Y1%,X2%,Y2%,LC%())
FORN%=1TO3:LC%(1,N%)=MC%(1,N%):LC%(2,N%)=FC%(2,N%)
LC%(3,N%)=MC%(2,N%):LC%(4,N%)=MC%(5,N%):NEXT
PROCA(X2%,Y1%,X3%,Y2%,LC%())
FORN%=1TO3:LC%(1,N%)=MC%(4,N%):LC%(2,N%)=MC%(5,N%)
LC%(3,N%)=MC%(3,N%):LC%(4,N%)=FC%(4,N%):NEXT
PROCA(X1%,Y2%,X2%,Y3%,LC%())
FORN%=1TO3:LC%(1,N%)=MC%(5,N%):LC%(2,N%)=MC%(2,N%)
LC%(3,N%)=FC%(3,N%):LC%(4,N%)=MC%(3,N%):NEXT
PROCA(X2%,Y2%,X3%,Y3%,LC%())
ENDIF
ENDPROC
DEFPROCP(X%,Y%,R%,G%,B%)
LOCAL C%
C%=RND(-X%*Y%-F%):R%=FNR(R%):G%=FNR(G%):B%=FNR(B%)
REMC%=(R%<<8)+(G%<<16)+(B%<<24)
REMSYS "ColourTrans_SetGCOL",C%,,,&100,0
COLOUR 15, R%, G%, B%
PLOT X%,Y%
PLOT 2+X%,Y%
ENDPROC
DEFFNR(R%)
R%=R%+RND(32)-16
IF R%>255 R%=255
IF R%<0 R%=0
=R%
Code:
REM > DRAMATIC2
REM by Jan Vibe
REM Adapted for BB4W by DW
MODE8:OFF
GCOL 15
DIM A%(319,255)
A%(000,000)=RND:PROCA(A%(0,0),0,0)
A%(319,000)=RND:PROCA(A%(255,0),1020,0)
A%(000,255)=RND:PROCA(A%(0,255),000,1020)
A%(319,255)=RND:PROCA(A%(255,255),1020,1020)
PROCF(0,0,319,255)
END
DEFPROCF(X1%,Y1%,X3%,Y3%)
LOCAL X2%,Y2%,P%,R%,G%,B%
P%=X3%-X1%:IF P%>=2 THEN
X2%=(X1%+X3%)/2:Y2%=(Y1%+Y3%)/2
PROCS(X1%,Y2%,X1%,Y1%,X1%,Y3%):PROCS(X2%,Y3%,X1%,Y3%,X3%,Y3%)
PROCS(X3%,Y2%,X3%,Y3%,X3%,Y1%):PROCS(X2%,Y1%,X1%,Y1%,X3%,Y1%)
IF RND(1)>.5 THEN
PROCS(X2%,Y2%,X1%,Y2%,X3%,Y2%)
ELSE
PROCS(X2%,Y2%,X2%,Y1%,X2%,Y3%)
ENDIF
PROCF(X1%,Y1%,X2%,Y2%):PROCF(X1%,Y2%,X2%,Y3%)
PROCF(X2%,Y2%,X3%,Y3%):PROCF(X2%,Y1%,X3%,Y2%)
ENDIF
ENDPROC
DEFPROCS(X%,Y%,X1%,Y1%,X2%,Y2%)
IF A%(X%,Y%)=0 THEN
A%(X%,Y%)=FNP(A%(X1%,Y1%),A%(X2%,Y2%)):PROCA(A%(X%,Y%),4*X%,4*Y%)
ENDIF
ENDPROC
DEFFNP(P1%,P2%)
LOCAL R1%,R2%,G1%,G2%,B1%,B2%,R%,G%,B%,PX%:PX%=P%*4
P1%=P1%>>8:R1%=P1%AND&FF:P1%=P1%>>8:G1%=P1%AND&FF:P1%=P1%>>8:B1%=P1%AND&FF
P2%=P2%>>8:R2%=P2%AND&FF:P2%=P2%>>8:G2%=P2%AND&FF:P2%=P2%>>8:B2%=P2%AND&FF
R%=FNM(R1%,R2%,PX%):G%=FNM(G1%,G2%,PX%):B%=FNM(B1%,B2%,PX%)
=(R%<<8)+(G%<<16)+(B%<<24)
DEFFNM(C1%,C2%,P%)
LOCAL C%
C%=(C1%+C2%)/2+RND(P%)-P%/2+RND(17)-9
IF C%>255 C%=255
IF C%<0 C%=0
=C%
DEFPROCA(A%,X%,Y%)
LOCAL R%,G%,B%
A%=A%>>8:R%=A%AND&FF:A%=A%>>8:G%=A%AND&FF:A%=A%>>8:B%=A%AND&FF
PROCRGB(R%,G%,B%):REMLINE X%,Y%,X%+2,Y%
RECTANGLE FILL X%,Y%,4,4
ENDPROC
DEFPROCRGB(R%,G%,B%)
LOCAL C%:C%=(R%<<8)+(G%<<16)+(B%<<24)
REMSYS "ColourTrans_SetGCOL",C%,,,&100,0
COLOUR 15, R%, G%, B%
ENDPROC
More coming soon :D
--
Re: Some RISC OS graphical ditties converted to BB
Post by dfeugey on Nov 9th, 2015, 1:34pm
Hope you'll put all of this on your website (both ROS and Windows versions). Useful code...
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 9th, 2015, 4:01pm
on Nov 9th, 2015, 1:34pm, dfeugey wrote:Hope you'll put all of this on your website (both ROS and Windows versions). Useful code...
|
|
Well, possibly. In the meantime, here's some more:
Code: REM > ELASTICNET *** Jan Vibe february 94 ***
REM by Jan Vibe
REM Adapted for BB4W by DW
REM Original version had W%=7 and H%=5
REM This version has W%=12 and H%=10
REMMODE140:MODE12:OFF:COLOUR0,0,0,255
*FLOAT 64
MODE 8 : OFF
COLOUR 0, 0, 0, 255 : CLG
PRINT'TAB(34)"Elastic net"''
PRINTTAB(10)"This program simulates a elastic net with balls attached"
PRINTTAB(10)"to the knots."'
PRINTTAB(10)"You can move a ball by moving the mousepointer over the"
PRINTTAB(10)"ball, and click the left mousebutton. As long as you hold"
PRINTTAB(10)"the button depressed, the ball follows the mouse. When"
PRINTTAB(10)"you release the button, the ball snaps back."'
PRINTTAB(10)"You can fix balls by moving the moving the pointer over"
PRINTTAB(10)"the ball, and click the right mousebutton. This stops"
PRINTTAB(10)"the ball from moving. Getting the right ball when the net"
PRINTTAB(10)"is moving can be real tricky. Fixed balls can also be"
PRINTTAB(10)"moved with the pointer."'
PRINTTAB(10)"You can release fixed balls by moving the pointer over the"
PRINTTAB(10)"over the ball, and click the the middle mousebutton."
PRINTTAB(10,25)"Click the mouse to continue.":VDU30
REPEAT:MOUSE A%,B%,C%:UNTIL C%<>0:CLS:K=INKEY(50)
REM W%=7 :REM Width in balls
REM H%=5 :REM height in balls
W%=12 :REM Width in balls
H%=10 :REM height in balls
WX%=1000 :REM Width in pixels
HY%=800 :REM Height in pixels
V%=6 :REM Weight of the balls
T=0.5 :REM Balls tendency to stay where it is put originally
D=0.99 :REM Damping factor
G=5 :REM Gravity
P1%=1:P2%=2:S1%=1:S2%=2:PX%=0:PY%=0
WD=(1280-WX%)/2:WB=WX%/(W%-1):HD=(1024-HY%)/2:HB=HY%/(H%-1)
DIM X(W%,H%,2),Y(W%,H%,2),DX(W%,H%),DY(W%,H%),F%(W%,H%)
DIM OX(W%,H%),OY(W%,H%)
REM This stops top row from moving
FORN%=1TOW%:F%(N%,H%)=1:NEXT
REM placing of balls
FORJ%=1TOH%:FORI%=1TOW%
X(I%,J%,P1%)=WD+(I%-1)*WB:Y(I%,J%,P1%)=HD+(J%-1)*HB
OX(I%,J%)=X(I%,J%,P1%):OY(I%,J%)=Y(I%,J%,P1%)
NEXT,
REMONERRORGOTO920
REM*POINTER
*REFRESH OFF
REM Screen and mouse control
REPEAT
REMSYS 6,112,S1%:SYS 6,113,S2%:WAIT:CLS:SWAP S1%,S2%
CLS
GPX%=PX%:GPY%=PY%:PX%=0:PY%=0:MOUSE XM,YM,BM%
IF BM%<>0 THEN
DL=1E9:FORJ%=1TOH%:FORI%=1TOW%
DM=(X(I%,J%,P1%)-XM)^2+(Y(I%,J%,P1%)-YM)^2:IF DM<DL DL=DM:PX%=I%:PY%=J%
NEXT,:IF GPX%<>0 PX%=GPX%:PY%=GPY%
X(PX%,PY%,P1%)=XM:Y(PX%,PY%,P1%)=YM
IF BM%=1 F%(PX%,PY%)=1
IF BM%=2 F%(PX%,PY%)=0
ENDIF
SWAP P1%,P2%
REM drawing of net
FORJ%=1TOH%-1:FORI%=1TOW%-1
LINEX(I%,J%,P2%),Y(I%,J%,P2%),X(I%+1,J%,P2%),Y(I%+1,J%,P2%)
LINEX(I%,J%,P2%),Y(I%,J%,P2%),X(I%,J%+1,P2%),Y(I%,J%+1,P2%):NEXT,
FORN%=1TOW%-1
LINEX(N%,H%,P2%),Y(N%,H%,P2%),X(N%+1,H%,P2%),Y(N%+1,H%,P2%):NEXT
FORN%=1TOH%-1
LINEX(W%,N%,P2%),Y(W%,N%,P2%),X(W%,N%+1,P2%),Y(W%,N%+1,P2%):NEXT
FORJ%=1TOH%:FORI%=1TOW%:CIRCLEFILLX(I%,J%,P2%),Y(I%,J%,P2%),12:NEXT,
REM Calculate new position for net
FORJ%=1TOH%:FORI%=1TOW%
IF NOT(I%=PX%ANDJ%=PY%) THEN
IF F%(I%,J%)=1 THEN
X(I%,J%,P1%)=X(I%,J%,P2%):Y(I%,J%,P1%)=Y(I%,J%,P2%)
ELSE
WT=0:NX=0:NY=0
IF I%>1 THEN NX+=X(I%-1,J%,P2%):NY+=Y(I%-1,J%,P2%):WT+=1
IF I%<W% THEN NX+=X(I%+1,J%,P2%):NY+=Y(I%+1,J%,P2%):WT+=1
IF J%>1 THEN NX+=X(I%,J%-1,P2%):NY+=Y(I%,J%-1,P2%):WT+=1
IF J%<H% THEN NX+=X(I%,J%+1,P2%):NY+=Y(I%,J%+1,P2%):WT+=1
NX+=OX(I%,J%)*T:NY+=OY(I%,J%)*T:WT+=T
NX+=X(I%,J%,P2%)*V%:NY+=Y(I%,J%,P2%)*V%:WT+=V%
X(I%,J%,P1%)=NX/WT+DX(I%,J%):Y(I%,J%,P1%)=NY/WT+DY(I%,J%)
DX(I%,J%)=(X(I%,J%,P1%)-X(I%,J%,P2%))*D
DY(I%,J%)=(Y(I%,J%,P1%)-Y(I%,J%,P2%))*D-G
ENDIF
ENDIF
NEXT,
*REFRESH
WAIT 1
UNTIL0
REMSYS 6,112,S1%:REPORT:PRINT" at line "STR$ERL:ON
Code: REM > LEAF
REM by Jan Vibe
REM Adapted for BB4W by DW
MODE8:OFF:RESTORE:READ K%:REMGCOL 144 TINT 128:CLG
COLOUR 0,34,34,102 : CLG
COLOUR 4,51,119,51
COLOUR 6,187,119,51
COLOUR 12,51,255,51
DIMGX1(K%),GY1(K%),GX2(K%),GY2(K%),M%(K%),C%(K%),F%(K%)
FORN%=1TOK%:READGX1(N%),GY1(N%),GX2(N%),GY2(N%),M%(N%),C%(N%),F%(N%)
GX1(N%)=GX1(N%)/16:GY1(N%)=(GY1(N%)-8)/16
GX2(N%)=GX2(N%)/16:GY2(N%)=(GY2(N%)-8)/16
NEXT:PROCREPLACE(64,0,864,830,50,0,1,1)
END
DEFPROCREPLACE(X1,Y1,X2,Y2,L%,C%,M%,F%)
LOCAL DX,DY,X3,Y3,X4,Y4,N%
IF L%=0 OR (X2-X1)^2+(Y2-Y1)^2<=16 THEN
GCOL C%:MOVEX1,Y1:DRAWX2,Y2
ELSE
DX=X2-X1:DY=Y2-Y1
FORN%=1TOK%
IFF%=1 THEN
X3=DX*GX1(N%)-M%*DY*GY1(N%)+X1:Y3=DY*GX1(N%)+M%*DX*GY1(N%)+Y1
X4=DX*GX2(N%)-M%*DY*GY2(N%)+X1:Y4=DY*GX2(N%)+M%*DX*GY2(N%)+Y1
PROCREPLACE(X3,Y3,X4,Y4,L%-1,C%(N%),M%*M%(N%),F%(N%))
ELSE
PROCREPLACE(X1,Y1,X2,Y2,0,C%,M%,F%)
ENDIF
NEXT
ENDIF
ENDPROC
DATA 5 :REM Number of elements
REM x1,y1,x2,y2,mirror,colour,fertility
DATA 0, 8, 6, 8, 1, 6, 0
DATA 6, 8,16, 3, -1, 12, 1
DATA 6, 8,13,12, -1, 4, 1
DATA 3, 8, 4,10, 1, 12, 1
DATA 3, 8, 5, 5, -1, 4, 1
Code: REM > FERNS
REM by Jan Vibe
REM Adapted for BB4W by DW
MODE8:OFF
DIM Y%(320),C%(320)
FORN%=1TO319:C%(N%)=RND(15):NEXT
REPEAT
REPEAT:P%=RND(319):H%=Y%(P%):Q%=C%(P%)
IF Y%(P%-1)>H% H%=Y%(P%-1):Q%=C%(P%-1)
IF Y%(P%+1)>H% H%=Y%(P%+1):Q%=C%(P%+1)
H%=H%+4:Y%(P%)=H%:C%(P%)=Q%
GCOL Q%:PLOT 4*P%,H%
IF RND(1)>.99 C%(RND(319))=RND(15)
UNTILH%>=1020
MOVE0,4:MOVE1280,1024:PLOT&BD,0,0:Y%()-=4
WAIT 1
UNTIL0
Code: REM > TARTAN
REM by Jan Vibe
REM Adapted for BB4W by DW
MODE8:OFF
R1=(RND(1)-.5)*3:R2=(RND(1)-.5)*3
G1=(RND(1)-.5)*3:G2=(RND(1)-.5)*3
B1=(RND(1)-.5)*3:B2=(RND(1)-.5)*3
GCOL 15
FORY%=0TO1023STEP2
FORX%=0TO1279STEP2
R%=(SINRAD(R1*X%+R2*Y%)+1)*127
G%=(SINRAD(G1*X%+G2*Y%)+1)*127
B%=(SINRAD(B1*X%+B2*Y%)+1)*127
PROCP(X%,Y%,R%,G%,B%)
NEXT,
END
DEFPROCP(X%,Y%,R%,G%,B%)
LOCAL C%
R%=FNA(R%):G%=FNA(G%):B%=FNA(B%)
REMC%=(R%<<8)+(G%<<16)+(B%<<24)
REMSYS "ColourTrans_SetGCOL",C%,,,&100,0
COLOUR 15, R%, G%, B%
IF POINT(X%,Y%)=0 LINE X%,Y%,X%,Y%
ENDPROC
DEFFNA(A%)
A%=A%+RND(32)-16
IF A%>255 A%=255
IF A%<0 A%=0
=A%
Code: REM > STRUKFILL
REM by Jan Vibe
REM Adapted for BB4W by DW
MODE19:OFF
DIM PX%(10000),PY%(10000):PX%()=640:PY%()=512:P%=10
FORN%=1TOP%:PX%(N%)=RND(1280):PY%(N%)=RND(1024):NEXT
FORN%=1TO8:T1=RAD(45*N%+120):T2=RAD(45*N%+180):T3=RAD(45*N%+270)
COLOUR N%,127*(SINT1+1),127*(SINT2+1),127*(SINT3+1):NEXT
REPEAT:C%=0:RESTORE
R%=RND(P%):X%=PX%(R%):Y%=PY%(R%):PX%(R%)=PX%(P%):PY%(R%)=PY%(P%):P%-=1
FORI%=1TO8:READ A%,B%:C%+=1:X1%=X%+A%:Y1%=Y%+B%
IF POINT(X1%,Y1%)=0 GCOLC%:PLOT X1%,Y1%:P%+=1:PX%(P%)=X1%:PY%(P%)=Y1%
NEXT:UNTILP%=0
DATA -4,-4, 0,-4, 4,-4, 4,0, 4,4, 0,4, -4,4, -4,0
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 9th, 2015, 4:07pm
Dazzling:
Code: REM > NOVA
REM by Jan Vibe
REM Adapted for BB4W by DW
REM Includes from the BB4W Programmer's Reference (Wiki)
REMMODE9:OFF:REM:COLOUR0,0,0,240
MODE 8:OFF:PROCpaletted
@vdu%!248 = 2 : REM thicker line (larger points)
DIMX%(1,3000),Y%(1,3000),D%(1,3000),F%(1,3000),DX%(8),DY%(8),C%(15,3)
FORN%=0TO7:READA%,B%:DX%(N%)=4*A%:DY%(N%)=4*B%:NEXT
P1%=0:P2%=1:C1%=1:TI%=TIME:C%()=240
X%(P1%,C1%)=640:Y%(P1%,C1%)=512:D%(P1%,C1%)=RND(8)-1:F%(P1%,C1%)=RND(15)
REPEAT
SWAP P1%,P2%:C2%=C1%:C1%=0:F%=F%MOD15+1
FORN%=1TOC2%:PROCF
PX%=X%(P2%,N%):PY%=Y%(P2%,N%):PD%=D%(P2%,N%):PF%=F%(P2%,N%)
T%=0:REPEAT:T%+=1:DP%=(RND(3)+6+PD%)MOD8
K%=POINT(PX%+DX%(DP%),PY%+DY%(DP%)):UNTILK%=0 OR T%=3
IF K%=0 THEN
XP%=PX%+DX%(DP%):YP%=PY%+DY%(DP%):FP%=PF%:IFRND(1)>.7 FP%=PF%MOD15+1
C1%+=1:X%(P1%,C1%)=XP%:Y%(P1%,C1%)=YP%:D%(P1%,C1%)=DP%:F%(P1%,C1%)=FP%
GCOL FP%:LINE PX%,PY%,XP%,YP%
ENDIF
IFRND(1)>.65THEN
T%=0:REPEAT:T%+=1:DP%=RND(8)-1
K%=POINT(PX%+DX%(DP%),PY%+DY%(DP%)):UNTILK%=0 OR T%=3
IF K%=0 THEN
XP%=PX%+DX%(DP%):YP%=PY%+DY%(DP%):PF%=PF%:IFRND(1)>.7 FP%=PF%MOD15+1
C1%+=1:X%(P1%,C1%)=XP%:Y%(P1%,C1%)=YP%:D%(P1%,C1%)=DP%:F%(P1%,C1%)=FP%
GCOL FP%:LINE XP%,YP%,XP%,YP%
ENDIF
ENDIF
NEXT
UNTILC1%=0
REPEAT:PROCF:UNTIL0
DEFPROCF
LOCAL N%,M%
IF TIME>=TI% THEN
FORN%=14TO1STEP-1:FORM%=1TO3:C%(N%+1,M%)=C%(N%,M%):NEXT,
FORM%=1TO3:C%(0,M%)=C%(0,M%)+RND(13)+15
C%(1,M%)=127*(SINRADC%(0,M%)+1):NEXT
FORN%=1TO15:COLOURN%,C%(N%,1),C%(N%,2),C%(N%,3):NEXT
TI%=TIME+7
ENDIF
PROCanimate
ENDPROC
DATA-1,1, 0,1, 1,1, 1,0, 1,-1, 0,-1, -1,-1, -1,0
REM Code from the BB4W Programmer's Reference:
DEF PROCanimate
LOCAL C%, pal%()
DIM pal%(15)
SYS "GetPaletteEntries", @hpal%, 0, 16, ^pal%(0)
pal%() AND= &E0F0F0
FOR C% = 0 TO 15 : SWAP ?^pal%(C%), ?(2+^pal%(C%)) : NEXT
SYS "SetDIBColorTable", @memhdc%, 0, 16, ^pal%(0)
SYS "InvalidateRect", @hwnd%, 0, 0
ENDPROC
DEF PROCpaletted
LOCAL bits%, hbm%, oldbm%, bmih{}
DIM bmih{Size%, Width%, Height%, Planes{l&,h&}, BitCount{l&,h&}, \
\ Compression%, SizeImage%, XPelsPerMeter%, YPelsPerMeter%, \
\ ClrUsed%, ClrImportant%}
bmih.Size% = DIM(bmih{})
bmih.Width% = @vdu%!208
bmih.Height% = @vdu%!212
bmih.Planes.l& = 1
bmih.BitCount.l& = 4
SYS "CreateDIBSection", @memhdc%, bmih{}, 0, ^bits%, 0, 0 TO hbm%
IF hbm% = 0 ERROR 100, "Couldn't create DIBSection"
SYS "SelectObject", @memhdc%, hbm% TO oldbm%
SYS "DeleteObject", oldbm%
PROCanimate
ENDPROC
Code: REM > INFERNO
REM by Jan Vibe
REM Adapted for BB4W by DW
REMMODE27:OFF:PROCT
MODE 19 : OFF : PROCpaletted : PROCT
FORN%=0TO1280STEP2:GCOLRND(15):PLOT N%,0:NEXT
FORY%=2TO960STEP2
FORX%=0TO1280STEP2
R%=2*(RND(3)-2):C%=ABS(POINT(X%+R%,Y%-2)):IF RND(1)>.8 C%=C%MOD15+1
GCOLC%:LINE X%,Y%,X%,Y%:PROCT
NEXT X%
NEXT Y%
REPEAT:PROCT:UNTIL0
DEFPROCT
IF TIME>T% THEN
LOCAL F%:S%=S%MOD15+1
FORN%=1TO15:F%=(S%+N%)MOD15+1:COLOURF%,255,16*N%,0:NEXT
PROCanimate
T%=TIME+5
ENDIF
ENDPROC
REM Code from the BB4W Programmer's Reference:
DEF PROCanimate
LOCAL C%, pal%()
DIM pal%(15)
SYS "GetPaletteEntries", @hpal%, 0, 16, ^pal%(0)
pal%() AND= &E0F0F0
FOR C% = 0 TO 15 : SWAP ?^pal%(C%), ?(2+^pal%(C%)) : NEXT
SYS "SetDIBColorTable", @memhdc%, 0, 16, ^pal%(0)
SYS "InvalidateRect", @hwnd%, 0, 0
ENDPROC
DEF PROCpaletted
LOCAL bits%, hbm%, oldbm%, bmih{}
DIM bmih{Size%, Width%, Height%, Planes{l&,h&}, BitCount{l&,h&}, \
\ Compression%, SizeImage%, XPelsPerMeter%, YPelsPerMeter%, \
\ ClrUsed%, ClrImportant%}
bmih.Size% = DIM(bmih{})
bmih.Width% = @vdu%!208
bmih.Height% = @vdu%!212
bmih.Planes.l& = 1
bmih.BitCount.l& = 4
SYS "CreateDIBSection", @memhdc%, bmih{}, 0, ^bits%, 0, 0 TO hbm%
IF hbm% = 0 ERROR 100, "Couldn't create DIBSection"
SYS "SelectObject", @memhdc%, hbm% TO oldbm%
SYS "DeleteObject", oldbm%
PROCanimate
ENDPROC
Less dazzling, but pretty nonetheless:
Code: REM > STARFISH *** Jan Vibe december 93 ***
REM Adapted for BB4W by DW
MODE8:OFF
DIM X(200,15),Y(200,15),A%(200,15),B%(200,15):X()=-200
FORN%=1TO15:COLOUR N%,8*N%+127,16*N%,16*N%:NEXT
FORY%=0TO256STEP4:FORX%=0TO255STEP2:GCOLRND(15):PLOTX%,Y%:NEXT,
FORY%=0TO1023STEP128:FORX%=0TO1279STEP128
IF X%>=255ORY%>=255THEN
A%=RND(127):B%=RND(127):MOVEA%,B%:MOVEA%+127,B%+127:PLOT&BE,X%,Y%
ENDIF
NEXT,
P1%=0:P2%=1:C1%=6:R=50:S=3
FORN%=1TO6
X(N%,P1%)=640:Y(N%,P1%)=512:A%(N%,P1%)=60*N%:B%(N%,P1%)=RND(12)+3
NEXT
REPEAT
P2%=P1%:P1%=(P1%+1)MOD16:C2%=C1%:C1%=0:F=R/16
FORN%=1TOC2%
FORM%=1TO15:K%=(P2%+15-M%)MOD15+1
GCOLM%:CIRCLE FILL X(N%,K%),Y(N%,K%),R-F*M%
NEXT,
FORN%=1TOC2%
IF B%(N%,P2%)>0 THEN
C1%+=1:A%(C1%,P1%)=(A%(N%,P2%)+(RND(1)-.5)*(55-R)):T=RAD(A%(C1%,P1%))
X(C1%,P1%)=X(N%,P2%)+(R*SINT)/S:Y(C1%,P1%)=Y(N%,P2%)+(R*COST)/S
B%(C1%,P1%)=B%(N%,P2%)-1
ELSE
C1%+=1:A%(C1%,P1%)=(A%(N%,P2%)-RND(20)-20):T=RAD(A%(C1%,P1%))
X(C1%,P1%)=X(N%,P2%)+(R*SINT)/S:Y(C1%,P1%)=Y(N%,P2%)+(R*COST)/S
B%(C1%,P1%)=RND(12)+3
C1%+=1:A%(C1%,P1%)=(A%(N%,P2%)+RND(20)+20):T=RAD(A%(C1%,P1%))
X(C1%,P1%)=X(N%,P2%)+(R*SINT)/S:Y(C1%,P1%)=Y(N%,P2%)+(R*COST)/S
B%(C1%,P1%)=RND(12)+3
ENDIF
NEXT
R-=.85
UNTILR<=8
FORI%=1TO16
P2%=P1%:P1%=(P1%+1)MOD16:C2%=C1%:C1%=0:F=R/16
FORN%=1TOC2%
FORM%=1TO15:K%=(P2%+15-M%)MOD15+1
GCOLM%:CIRCLE FILL X(N%,K%),Y(N%,K%),R-F*M%
NEXT,
FORN%=1TOC2%:C1%+=1:X(N%,P1%)=-200:NEXT,
Jan Vibe was probably the master of RISC OS graphical 'ditties'; his programs were listed in Acorn User magazine every month in the late 80s up until the mid 90s.
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 10th, 2015, 1:38pm
This guy's certainly got a head for recursion:
Code: REM > MARBLEFILL *** Jan Vibe february 93 ***
REM Adapted for BB4W by DW
MODE9:OFF:HIMEM=PAGE+5*&100000
DIM GX%(4),GY%(4),V$(24)
FORN%=1TO4:READ GX%(N%),GY%(N%):NEXT
FORN%=1TO24:READV$(N%):NEXT
FORN%=1TO15:COLOUR N%,16*N%,16*N%,16*N%:NEXT
GCOL 7:@vdu%!248=2:CIRCLE 640,512,500:@vdu%!248=1
PROCA(640,512,V$(RND(24)))
END
DEFPROCA(X%,Y%,A$)
LOCALN%
T%=0:C%=0:FORM%=1TO4:K%=POINT(X%+GX%(M%),Y%+GY%(M%))
IF K%>0 C%+=K%:T%+=1
NEXT:IF T%=0 T%=1
GCOL (C%/T%+2*RND(1)+15.5)MOD16:PLOT X%,Y%
FORN%=1TO4:P%=VALMID$(A$,N%,1):X1%=X%+GX%(P%):Y1%=Y%+GY%(P%)
IF POINT(X1%,Y1%)=0 PROCA(X1%,Y1%,V$(RND(24)))
NEXT
ENDPROC
DATA -4,0, 4,0, 0,-4, 0,4
DATA 1234,1243,1324,1342,1423,1432,2134,2143,2314,2341,2413,2431
DATA 3124,3142,3214,3241,3412,3421,4123,4132,4213,4231,4312,4321
Code: REM > SEAWEED
REM by Jan Vibe
REM Adapted for BB4W by DW
REM MODE128:MODE0:OFF:COLOUR0,0,0,128
MODE 8:OFF:COLOUR0,0,0,128:CLG
DIM B%(128),D%(128)
REM S1%=1:S2%=2
FORN%=1TO128:B%(N%)=RND(31)-16:D%(N%)=RND(7)-4:NEXT
REM ONERRORGOTO300
*REFRESH OFF
REPEAT
REM SYS 6,112,S1%:SYS 6,113,S2%:WAIT:CLS:SWAP S1%,S2%
CLS
FORN%=1TO128
IFRND(1)>.9 D%(N%)=RND(7)-4
IF ABS(B%(N%)+D%(N%))>15 D%(N%)=-D%(N%)
B%(N%)+=D%(N%):NEXT
C%=0:PROCT(640,0,300,0,6)
*REFRESH
WAIT 4
UNTIL0
DEFPROCT(X%,Y%,Z%,A%,L%)
LOCAL X1%,Y1%,F
C%+=1:F=(7-L%)/1.5
X1%=X%+Z%*SINRAD(A%+F*B%(C%))
Y1%=Y%+Z%*COSRAD(A%+F*B%(C%))
LINE X%,Y%,X1%,Y1%
IF L%>0 THEN
PROCT(X1%,Y1%,Z%/1.4,A%-45,L%-1)
PROCT(X1%,Y1%,Z%/1.4,A%+45,L%-1)
ENDIF
ENDPROC
300 REM SYS 6,112,S1%:REPORT:PRINT" at line "STR$ERL:ON
Code: REM > SHATTER2 *** Jan Vibe may 93 ***
REM by Jan Vibe
REM Adapted for BB4W by DW
REM MODE140:MODE12:OFF
MODE 8:OFF
DIM TX%(50,15),TY%(50,15),TN%(50),AX%(15),AY%(15)
REM S1%=1:S2%=2
GCOL 15
*REFRESH OFF
REPEAT
V%=RND(6)+2:TN%(1)=V%:D=360/V%
FORN%=1TOV%:T=RAD(360-N%*D)
TX%(1,N%)=640+300*SINT:TY%(1,N%)=512+300*COST
NEXT
FORI%=1TO49
IF I%=1 THEN
R%=1
ELSE
MAX%=0:FORN%=1TOI%
X1%=0:Y1%=0
FORM%=1 TO TN%(N%):X1%+=TX%(N%,M%):Y1%+=TY%(N%,M%):NEXT
X1%=X1%/TN%(N%):Y1%=Y1%/TN%(N%)
A%=0:FORM%=1TOTN%(N%):M1%=M%MODTN%(N%)+1
X2%=TX%(N%,M%):Y2%=TY%(N%,M%):X3%=TX%(N%,M1%):Y3%=TY%(N%,M1%)
A%+=(X1%*Y2%+Y1%*X3%+Y3%*X2%-Y2%*X3%-Y1%*X2%-X1%*Y3%)/2
NEXT
IF A%>MAX% MAX%=A%:R%=N%
NEXT
ENDIF
P%=TN%(R%)
FORN%=1TOP%:AX%(N%)=TX%(R%,N%):AY%(N%)=TY%(R%,N%):NEXT
L%=0:FORN%=1TOP%:N1%=N%MODP%+1
G%=(AX%(N%)-AX%(N1%))^2+(AY%(N%)-AY%(N1%))^2
IF G%>L% L%=G%:D11%=N%
NEXT
REPEAT:D21%=RND(P%):UNTIL D11%<>D21%
IF D11%>D21% SWAP D11%,D21%
D12%=D11%MODP%+1:D22%=D21%MODP%+1
F1%=RND(2):F2%=3-F1%
PX1%=(F1%*AX%(D11%)+F2%*AX%(D12%))/3
PY1%=(F1%*AY%(D11%)+F2%*AY%(D12%))/3
PX2%=(F1%*AX%(D21%)+F2%*AX%(D22%))/3
PY2%=(F1%*AY%(D21%)+F2%*AY%(D22%))/3
K%=0:FORN%=1TOP%
K%+=1:TX%(R%,K%)=AX%(N%):TY%(R%,K%)=AY%(N%)
IF N%=D11% THEN
K%+=1:TX%(R%,K%)=PX1%:TY%(R%,K%)=PY1%
K%+=1:TX%(R%,K%)=PX2%:TY%(R%,K%)=PY2%
N%=D21%
ENDIF
NEXT:TN%(R%)=K%
Q%=I%+1
K%=1:TX%(Q%,K%)=PX1%:TY%(Q%,K%)=PY1%
FORN%=D11%+1TOD21%
K%+=1:TX%(Q%,K%)=AX%(N%):TY%(Q%,K%)=AY%(N%)
NEXT
K%+=1:TX%(Q%,K%)=PX2%:TY%(Q%,K%)=PY2%:TN%(Q%)=K%
NEXT
REM ONERRORGOTO790
FORI%=0TO20
REM SYS 6,112,S1%:SYS 6,113,S2%:WAIT:CLS:SWAP S1%,S2%
CLS
FORN%=1TO50
PROCD(N%,I%/30)
NEXT N%
*REFRESH
WAIT 5
NEXT I%
REM SYS 6,112,S1%:SYS 6,113,S2%:WAIT:CLS:SWAP S1%,S2%
WAIT 100
UNTIL0
DEFPROCD(P%,F)
LOCAL N%,CX%,CY%,MX%,MY%,X%,Y%,F1
FORN%=1TOTN%(P%):CX%+=TX%(P%,N%):CY%+=TY%(P%,N%):NEXT
CX%=CX%/TN%(P%):CY%=CY%/TN%(P%)
MX%=(CX%-640):MY%=(CY%-512):F1=F+1
X%=TX%(P%,TN%(P%))-640
Y%=TY%(P%,TN%(P%))-512
MOVEX%+MX%*F+640,Y%+MY%*F+512
FORN%=1TOTN%(P%)
X%=TX%(P%,N%)-640
Y%=TY%(P%,N%)-512
MOVE MX%*F1+640,MY%*F1+512
PLOT85,X%+MX%*F+640,Y%+MY%*F+512
NEXT
ENDPROC
REM SYS 6,112,S1%:REPORT:PRINT" at line "STR$ERL:ON
Code: REM > ICE2
REM by Jan Vibe
MODE8:OFF:GCOL 15
DIM X(500,2),Y(500,2),DX(500,2),DY(500,2),A(500,2)
REPEAT:CLS:T1%=1:P1%=1:P2%=2:Q=.2:X(T1%,P1%)=640:Y(T1%,P1%)=512
A(T1%,P1%)=RND(360):T=RADA(T1%,P1%)
DX(T1%,P1%)=5*SINRADT:DY(T1%,P1%)=5*COST
REPEAT:T2%=0
FORN%=1TOT1%
NX=X(N%,P1%)+DX(N%,P1%):NY=Y(N%,P1%)+DY(N%,P1%)
IF POINT(NX,NY)=0 THEN
T2%+=1:X(T2%,P2%)=NX:Y(T2%,P2%)=NY
DX(T2%,P2%)=DX(N%,P1%):DY(T2%,P2%)=DY(N%,P1%):A(T2%,P2%)=A(N%,P1%)
LINE X(N%,P1%),Y(N%,P1%),NX,NY
IFRND(1)>Q THEN
T2%+=1:X(T2%,P2%)=NX:Y(T2%,P2%)=NY:M%=0
REPEAT:M%+=1:A(T2%,P2%)=(RND(120)+A(N%,P1%)+300)MOD360:T=RADA(T2%,P2%)
DX(T2%,P2%)=5*SINT:DY(T2%,P2%)=5*COST
UNTIL POINT(NX+DX(T2%,P2%),NY+DY(T2%,P2%))=0 OR M%=5
IF M%=5 T2%-=1
ENDIF
ENDIF
NEXT
SWAP T1%,T2%:SWAP P1%,P2%:Q=.9:IF T1%<10 Q=.8
UNTIL T1%=0
K=INKEY(300)
UNTIL0
Code: REM > GRANITE
REM by Jan Vibe
REM Adapted for BB4W by DW
MODE9:OFF:FORN%=0TO15:COLOUR N%,16*N%,16*N%,16*N%:NEXT:FORY%=4TO1016STEP4:FORX%=4TO1272STEP4:C%=POINT(X%-4,Y%)+POINT(X%-4,Y%-4)+POINT(X%,Y%-4)+POINT(X%+4,Y%-4):GCOL(C%/4+8*(RND(1)-.44))MOD16:PLOTX%,Y%:NEXT,
Code: REM > MAZE
REM by Jan Vibe
REM Adapted for BB4W by DW (may be slightly incorrect)
MODE8:OFF:B%=12
RECTANGLE 640-2*B%,512-2*B%,4*B%:MOVE640-2*B%,512+2*B%:PLOT2,0,-B%+4
PROCA(640-2*B%,512+2*B%)
END
DEFPROCA(X%,Y%)
LOCALN%
FORN%=1TO8
B1%=B%*SGN(RND(1)-.5):B2%=0:IFRND(1)>.5 SWAP B1%,B2%
X1%=X%+B1%:Y1%=Y%+B2%
IF POINT(X1%,Y1%)=0 LINE X%,Y%,X1%,Y1%:PROCA(X1%,Y1%)
NEXT
ENDPROC
Re: Some RISC OS graphical ditties converted to BB
Post by DDRM on Nov 18th, 2015, 08:18am
Hi David,
I well remember the "Vibe-isms" from the 80's and 90's Acorn User magazine. What always impressed me was his ability to get so much out of such small amounts of code. Of the examples you posted, the maze one is amazing (sorry, couldn't resist!).
While looking (again) at maze-drawing algorithms in Wikipedia, I saw the section on cellular automata that generate maze-like conformations, so I thought I'd have a go.
While the basic automaton generates maze-LIKE patterns, making it into a fully connected maze, with a guaranteed route from start to finish means some post processing. I've put in some such code, though there are circumstances in which (usually very small) sections remain isolated. Note that this algorithm does NOT guarantee a unique route through the maze - and there can be circular routes, so simple maze-solving algorithms (such as wall-following) will fail!
Here's the code, if anyone wants a play. Try changing the maximum number of neighbours, and/or the probability of a space starting with a cell in it.
Code:
REM Maze-generating cellular automaton
MODE 21
NoOfSquares%=32
maxneighbours%=4 :REM Try changing to 5
Startingprob=0.3 :REM Probability that a square will start with a cell in it
sf%=1024/NoOfSquares%
DIM m%(NoOfSquares%,NoOfSquares%,1)
FOR x%=1 TO NoOfSquares%-1
FOR y%=1 TO NoOfSquares%-1
IF RND(1)<Startingprob THEN m%(x%,y%,0)=1
NEXT y%
NEXT x%
l%=0
l1%=1
cownt%=0
REM Here's the cellular automaton section
REPEAT
cownt%+=1
changes%=0
FOR x%=1 TO NoOfSquares%-1
FOR y%=1 TO NoOfSquares%-1
m%(x%,y%,l1%)=m%(x%,y%,l%)
c%=m%(x%-1,y%-1,l%)+m%(x%-1,y%,l%)+m%(x%-1,y%+1,l%)+m%(x%,y%-1,l%)+m%(x%,y%+1,l%)+m%(x%+1,y%-1,l%)+m%(x%+1,y%,l%)+m%(x%+1,y%+1,l%)
IF c%=3 AND m%(x%,y%,l%)=0 THEN changes%+=1:m%(x%,y%,l1%)=1
IF (c%=0 OR c%>maxneighbours%) AND (m%(x%,y%,l%)=1) THEN changes%+=1:m%(x%,y%,l1%)=0
NEXT y%
NEXT x%
SWAP l%,l1%
PROCDraw(l%)
UNTIL changes%=0 OR cownt%>50
REM Open entrance and exit
py%=NoOfSquares%/2
px%=NoOfSquares%
m%(px%,py%,l%)=1
m%(px%-1,py%,l%)=1
px%=0
m%(px%,py%,l%)=1
m%(px%+1,py%,l%)=1
PROCDraw(l%)
REM PROCvisit tries out all the pathways from a given point, setting flags in visited squares
PROCvisit(px%,py%)
REM Identify unconnected sections and try to connect them
FOR x%=1 TO NoOfSquares%-1
FOR y%=1 TO NoOfSquares%-1
IF m%(x%,y%,l%)=1 THEN
isolated%=TRUE
IF x%>2 THEN
IF m%(x%-2,y%,l%)=2 THEN m%(x%-1,y%,l%)=1:PROCvisit(x%-1,y%):PROCDraw(l%):isolated%=FALSE
ENDIF
IF x%<NoOfSquares%-2 AND isolated% THEN
IF m%(x%+2,y%,l%)=2 THEN m%(x%+1,y%,l%)=1:PROCvisit(x%+1,y%):PROCDraw(l%):isolated%=FALSE
ENDIF
IF y%>2 AND isolated% THEN
IF m%(x%,y%-2,l%)=2 THEN m%(x%,y%-1,l%)=1:PROCvisit(x%,y%-1):PROCDraw(l%):isolated%=FALSE
ENDIF
IF y%<NoOfSquares%-2 AND isolated% THEN
IF m%(x%,y%+2,l%)=2 THEN m%(x%,y%+1,l%)=1:PROCvisit(x%,y%+1):PROCDraw(l%):isolated%=FALSE
ENDIF
ENDIF
NEXT y%
NEXT x%
PROCDraw(l%)
WAIT 20
REM Let's clear it and re-traverse the maze, to check we can get from start to finish!
PROCClear(l%)
PROCDraw(l%)
WAIT 20
PROCvisit(0,NoOfSquares%/2)
PROCDraw(l%)
END
:
DEFPROCDraw(n%)
LOCAL x%,y%
REM CLS
FOR x%=0 TO NoOfSquares%
FOR y%=0 TO NoOfSquares%
CASE m%(x%,y%,n%) OF
WHEN 0 GCOL 15 :REM Wall
WHEN 1 GCOL 0 :REM passage
WHEN 2 GCOL 1 :REM Visited passage
ENDCASE
RECTANGLE FILL sf%*x%,sf%*y%,sf%,sf%
NEXT y%
NEXT x%
ENDPROC
:
DEFPROCvisit(px%,py%)
IF m%(px%,py%,l%)<>1 THEN ENDPROC
m%(px%,py%,l%)=2
IF px%<NoOfSquares% THEN PROCvisit(px%+1,py%)
IF py%<NoOfSquares% THEN PROCvisit(px%,py%+1)
IF px%>0 THEN PROCvisit(px%-1,py%)
IF py%>0 PROCvisit(px%,py%-1)
ENDPROC
:
DEFPROCClear(l%)
LOCAL x%,y%
FOR x%=0 TO NoOfSquares%
FOR y%=0 TO NoOfSquares%
IF m%(x%,y%,l%)=2 THEN m%(x%,y%,l%)=1
NEXT y%
NEXT x%
ENDPROC
Best wishes,
D
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 18th, 2015, 6:16pm
on Nov 18th, 2015, 08:18am, DDRM wrote:Hi David,
I well remember the "Vibe-isms" from the 80's and 90's Acorn User magazine. What always impressed me was his ability to get so much out of such small amounts of code. Of the examples you posted, the maze one is amazing (sorry, couldn't resist!). |
|
Indeed, and in fact I was just trying to track down his circular maze drawer. If I can find it, I'll adapt it and put it up here. His 'crop circle'-drawing one-liner is really excellent.
It was from one of his programs that I learnt how to do screen bank swapping (I didn't have the RISC OS Programmer's Reference Manual):
Code:J%=1:K%=2
REPEAT
WAIT : CLS
<...draw graphics...>
SYS 6, 112, J%
SYS 6, 113, K%
SWAP J%, K%
UNTIL FALSE
That bit of code found its way into practically every program I ever wrote for RISC OS!
Quote:| While looking (again) at maze-drawing algorithms in Wikipedia, I saw the section on cellular automata that generate maze-like conformations, so I thought I'd have a go. |
|
Interesting and rather entertaining to watch (even more so after setting NoOfSquares% to a higher value such as 64)! I had never heard of automaton-generated mazes until now, but then I've never really looked into maze generation. I once made a Wolfenstein-style 3D maze demo (based on D3DLIB), all orthogonal walls, where I created the maze the tedious way - using a custom-built editor. I think that using a maze generator (such as yours) would have been more interesting and probably less time-consuming. Anyway, I think your code (comprehensible as usual) is particularly informative to those trying to get their head around recursion! I must admit, I don't think I've ever employed such techniques in my projects, but only because I haven't got the head for it.
David.
--
PS. Bonus for the interested: Here's a little Vibe-esque demo (EXE - the included source requires GFXLIB). Actually, it came about from a need to draw random, twisty curves for a game I'm making. The method I came up with seems to do a reasonable job. http://www.proggies.uk/bb4w/ropefade.zip
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 22nd, 2015, 1:29pm
Perhaps someone else could have a go at porting the next one? The code listed below will run without errors, but the result is not correct! The program makes effective use of RISC OS's ECF (Extended Colour Fill) patterns (VDU 23, [2 to 5], ...), not supported by BB4W (they're not really needed since the RISC OS version runs in 16-colour mode 12 (640x512 and those horrible 'tall' pixels), and BB4W can display 'True Colour' making dithering patterns unnecessary).
This is what you should see in an appropriately modified version:
http://www.proggies.uk/bb4w/img/jvibe_wheel_scrshot.gif
Below is Jan Vibe's original, unmolested code:
Code:
10REM > WHEEL
20
30MODE12:ORIGIN 640,512:OFF
40FORN%=0TO15:COLOUR N%,16*N%,0,16*(15-N%):NEXT
50FORM%=82TO0STEP-1:Z%=10*M%
60FORN%=1TO240
70C%=(N%+M%)MOD30
80A%=(N%+M%)DIV30
90B%=A%MOD2
100IF B%=0 C%=30-C%
110PROCC(C%)
120MOVE 0,0:MOVE Z%*SINRAD(1.5*N%),Z%*COSRAD(1.5*N%)
130PLOT85,Z%*SINRAD(1.5*(N%+1)),Z%*COSRAD(1.5*(N%+1))
140NEXT,
150END
160
170DEFPROCC(A%)
180LOCAL P1%,P2%
190A%=A%MOD31
200IF A%MOD2=0 THEN
210 GCOL A%DIV2
220ELSE
230 A%=A%DIV2
240 P1%=FNA(A%,A%+1)
250 P2%=FNA(A%+1,A%)
260 VDU23,2,P1%,P2%,P1%,P2%,P1%,P2%,P1%,P2%
270 GCOL16,0
280ENDIF
290ENDPROC
300
310DEFFNA(A%,B%)
320LOCAL N%,C%,AB%
330C%=8
340FORN%=1TO4
350AB%=AB%<<1:IF C%ANDA% AB%+=1
360AB%=AB%<<1:IF C%ANDB% AB%+=1
370C%=C%/2:NEXT
380=AB%
Re: Some RISC OS graphical ditties converted to BB
Post by DDRM on Nov 22nd, 2015, 9:57pm
Hi David,
Something like this?
Code:
REM > WHEEL
MODE8:ORIGIN 640,512:OFF
GCOL 15
da=PI/120
FOR M%=82 TO 0 STEP -1
Z%=10*M%
FOR N%=1 TO 240
C%=(N%+M%) MOD 30
IF ((N%+M%) DIV 30) MOD 2 =0 THEN C%=30-C%
COLOUR 15,C%*8,0,(30-C%)*8
MOVE 0,0:MOVE Z%*SIN(N%*da),Z%*COS(N%*da)
PLOT85,Z%*SIN((N%+1)*da),Z%*COS((N%+1)*da)
NEXT N%
NEXT M%
END
I haven't tried to reproduce the dithering, I've just used the better colour options of BB4W! Makes life much easier...
By the way, I don't recall ever seeing NEXT, to close all the open FOR-NEXT loops!
:-)
D
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 22nd, 2015, 11:43pm
on Nov 22nd, 2015, 9:57pm, DDRM wrote:Hi David,
Something like this? |
|
Yes! Clever. Neatly wrapped up in a few lines of BASIC. When I first saw the original program run (under RISC OS on RPCEmu), and glanced at the code, I wondered how he got such smooth colour gradations in a 16-colour mode. Then I looked up VDU 23, 2, ... and there was the answer. The dithering in the original version is practically imperceptible (at least to my eyes).
Anyway, thanks for successfully meeting the challenge!
Quote:| By the way, I don't recall ever seeing NEXT, to close all the open FOR-NEXT loops! |
|
I noticed he does that in many of his programs. The reason behind it might be primarily speed - perhaps there's a small boost. He was writing many of his graphical 'ditties' on a relatively slow ARM2-based machine, so shaving off a few dozen clock cycles here and there may have been worthwhile.
Incidentally, here is his circular maze drawing program which I mentioned in a previous post. The only change I had to make was the display mode, and draw thicker lines (see what happens if you remove the @vdu%!248=2 statement!).
By the way, it may not be a 'true' maze! I haven't checked.
Code:
REM > MAZE
REM by Jan Vibe
REM Adapted for BB4W by DW
MODE 8
VDU5:MOVE 610,524:PRINT"Goal":VDU4:OFF
@vdu%!248 = 2
CIRCLE 640,512,500:CIRCLE 640,512,64
PROCA(400,512)
GCOL0:CIRCLE 640,512,500:CIRCLE 640,512,64:ON
@vdu%!248 = 1
END
DEFPROCA(X%,Y%)
LOCAL N%
FOR N%=1TO8:T=RADRND(360):X1%=X%+16*SINT:Y1%=Y%+16*COST
C%=0:FORI%=-8TO8STEP2
IF POINT(X1%+I%,Y1%+8)<>0 C%+=1
IF POINT(X1%+I%,Y1%-8)<>0 C%+=1
NEXT:FORI%=-4TO4STEP4
IF POINT(X1%+8,Y1%+I%)<>0 C%+=1
IF POINT(X1%-8,Y1%+I%)<>0 C%+=1
NEXT:IF C%<1 LINE X%,Y%,X1%,Y1%:PROCA(X1%,Y1%)
NEXT
ENDPROC
David.
--
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 23rd, 2015, 12:44pm
More:
Code: REM > SQUIGG2
REM by Jan Vibe
REM Adapted for BB4W by DW
REMSYS"OS_UpdateMEMC",64,64
REMONERRORGOTO 370
REMMODE0:MODE128:OFF
MODE 8 : OFF
DIMA%(4),X%(180,2),Y%(180,2)
N%=RND(-TIME)
FORN%=1TO4:A%(N%)=2*RND(6):NEXT
FORN%=1TO180
X%(N%,1)=500*SINRAD(A%(1)*N%)*COSRAD(A%(2)*N%)+640
Y%(N%,1)=500*SINRAD(A%(3)*N%)*COSRAD(A%(4)*N%)+512
NEXT
REMA$="1":B$="2"
C%=2:K%=60
*REFRESH OFF
REPEAT
D%=C%:C%=3-C%
FORN%=1TO4:A%(N%)=2*RND(6):NEXT
FORN%=1TO180
X%(N%,D%)=500*SINRAD(A%(1)*N%)*COSRAD(A%(2)*N%)+640
Y%(N%,D%)=500*SINRAD(A%(3)*N%)*COSRAD(A%(4)*N%)+512
NEXT
FORI%=0TOK%
FORN%=1TO180
X%(N%,0)=(I%*X%(N%,D%)+(K%-I%)*X%(N%,C%))/K%
Y%(N%,0)=(I%*Y%(N%,D%)+(K%-I%)*Y%(N%,C%))/K%
NEXT
CLS
MOVEX%(180,0),Y%(180,0):FORN%=1TO180:DRAWX%(N%,0),Y%(N%,0):NEXT
REMOSCLI"FX 112,"+A$
REMOSCLI"FX 113,"+B$
REMSWAP A$,B$
REMWAIT:CLS
*REFRESH
WAIT 1
NEXT
UNTIL0
REMOSCLI"FX112,"+A$:ON:REPORT:PRINT" at line "STR$ERL
Code: REM > SQUIGG5
REM by Jan Vibe
REM Adapted for BB4W by DW
REMSYS"OS_UpdateMEMC",64,64
REMMODE128:MODE0:OFF:ORIGIN 640,512
MODE 8:OFF:ORIGIN 640,512
REMS1%=1:S2%=2
D1%=1:D2%=2:I%=64:K%=I%
DIM PX%(120,2),PY%(120,2)
PROCA(1):PROCA(2)
REMONERRORGOTO310
*REFRESH OFF
REPEAT
CLS
REMSYS 6,112,S1%:SYS 6,113,S2%:WAIT:CLS:SWAP S1%,S2%
IF K%=0 SWAP D1%,D2%:PROCA(D2%):K%=I% ELSE K%-=1
MOVE170,170:FORN%=1TO120
X=(PX%(N%,D1%)*K%+PX%(N%,D2%)*(I%-K%))/I%
Y=(PY%(N%,D1%)*K%+PY%(N%,D2%)*(I%-K%))/I%
DRAW X,Y:NEXT
ENDIF
*REFRESH
WAIT 1
UNTIL0
DEFPROCA(P%)
LOCAL N%,K1%,K2%,K3%,K4%,K5%,K6%,T
K1%=RND(10):K2%=RND(10):K3%=RND(10)
K4%=RND(10):K5%=RND(10):K6%=RND(10)
FORN%=1TO120:T=RAD(N%*3)
X=170*(SIN(K1%*T)+COS(K2%*T)+SIN(K3%*T))
Y=170*(SIN(K4%*T)+COS(K5%*T)+SIN(K6%*T))
PX%(N%,P%)=X:PY%(N%,P%)=Y
NEXT
ENDPROC
REMSYS 6,112,S1%:REPORT:PRINT" at line "STR$ERL:ON
Code: REM > WBLOCKS
REM by Jan Vibe
REM Adapted for BB4W by DW
REMMODE12:ORIGIN 0,256:OFF
MODE 8 : ORIGIN 0,256 : OFF
REMSYS"OS_UpdateMEMC",64,64
REMONERRORGOTO290
DIM A%(18,15):REMS1$="1":S2$="2"
*REFRESH OFF
REPEAT
FORN%=14TO0STEP-1:FORM%=0TO18:A%(M%,N%+1)=A%(M%,N%):NEXT,
K%=(K%+20)MOD360:Z%=128*SINRAD(K%+10)
REMOSCLI"FX112,"+S1$:OSCLI"FX113,"+S2$:WAIT:SWAPS1$,S2$:CLS
CLS
FORN%=0TO18
A%(N%,0)=Z%*SINRAD(30*N%+15)
NEXT
FORN%=15TO0STEP-1
FORM%=0TO18
X1%=56*M%+12*N%:Y1%=A%(M%,N%)+32*N%
X6%=X1%:Y6%=32*N%-128
X5%=X6%+56:Y5%=Y6%
X7%=X5%:Y7%=Y1%
X2%=X1%+12:Y2%=Y1%+32
X3%=X2%+56:Y3%=Y2%
X4%=X5%+12:Y4%=Y5%+32
GCOL1:MOVEX5%,Y5%:MOVEX4%,Y4%:PLOT&75,X3%,Y3%
GCOL2:MOVEX1%,Y1%:MOVEX7%,Y7%:PLOT&75,X3%,Y3%
GCOL4:MOVEX6%,Y6%:PLOT&65,X7%,Y7%
GCOL0:MOVEX1%,Y1%:DRAWX2%,Y2%:DRAWX3%,Y3%:DRAWX4%,Y4%:DRAWX5%,Y5%
DRAWX6%,Y6%:DRAWX1%,Y1%:DRAWX7%,Y7%:DRAWX5%,Y5%:LINEX7%,Y7%,X3%,Y3%
NEXT,
*REFRESH
WAIT 1
UNTIL0
REMOSCLI"FX112,"+S1$:REPORT:PRINT" at line "STR$ERL:ON
Code: REM > BLOBS
REM by Jan Vibe
REM Adapted for BB4W by DW
REM MODE12:MODE140:K%=20:OFF
MODE 8 : K%=20 : OFF
REMSYS"OS_UpdateMEMC",64,64
REMONERRORGOTO280
REMS1$="1":S2$="2"
DIMX%(K%),Y%(K%),R(K%),D(K%),DX%(K%),DY%(K%)
FORN%=1TOK%
R(N%)=64+RND(64):D(N%)=R(N%)/15
X%(N%)=R(N%)+RND(1280-2*R(N%))
Y%(N%)=R(N%)+RND(1024-2*R(N%))
DX%(N%)=4*RND(4)*SGN(RND(1)-.5)
DY%(N%)=4*RND(4)*SGN(RND(1)-.5)
NEXT
*REFRESH OFF
REPEAT
REMOSCLI"FX 112,"+S1$:OSCLI"FX113,"+S2$:WAIT:SWAP S1$,S2$:CLS
CLS
FORN%=1TO15:COLOUR N%,16*N%,16*N%,16*N%:NEXT
FORN%=1TO15:GCOL N%
FORM%=1TOK%:CIRCLE FILL X%(M%),Y%(M%),R(M%)-(N%-1)*D(M%)
NEXT,
FORN%=1TOK%
230 X1%=X%(N%)+DX%(N%):IFX1%-R(N%)<0ORX1%+R(N%)>1278 DX%(N%)=-DX%(N%):GOTO230
240 Y1%=Y%(N%)+DY%(N%):IFY1%-R(N%)<0ORY1%+R(N%)>1020 DY%(N%)=-DY%(N%):GOTO240
X%(N%)=X1%:Y%(N%)=Y1%:NEXT
*REFRESH
WAIT 1
UNTIL0
REMOSCLI"FX112,"+S1$:REPORT:PRINT" at line "STR$ERL:ON
Code: REM > WAVES
REM by Jan Vibe
REM Adapted for BB4W by DW
REMMODE12:ORIGIN 640,512:OFF:*FX10
MODE 8 : ORIGIN 640,512 : OFF : PROCpaletted
FORN%=1TO360:T=RADN%:K=10:SI=SINT:CO=COST
C%=7.5*(COSRAD(10*N%)+1):X=0:Y=0:MOVEX,Y
REPEAT:C%=C%MOD15+1:GCOL C%:K=K-.1:DX=K*SI:DY=K*CO
X=X+DX:Y=Y+DY:DRAW X,Y:UNTILK<=0:NEXT
C1%=1:C2%=9:REPEAT:C1%=C1%MOD15+1:C2%=C2%MOD15+1
WAIT:COLOUR C1%,255,255,255:COLOUR C2%,0,0,0
PROCanimate : WAIT 2
UNTIL0
REM The following code segment is from the
REM BB4W Programmer's Reference...
DEF PROCanimate
LOCAL C%, pal%()
DIM pal%(15)
SYS "GetPaletteEntries", @hpal%, 0, 16, ^pal%(0)
pal%() AND= &E0F0F0
FOR C% = 0 TO 15 : SWAP ?^pal%(C%), ?(2+^pal%(C%)) : NEXT
SYS "SetDIBColorTable", @memhdc%, 0, 16, ^pal%(0)
SYS "InvalidateRect", @hwnd%, 0, 0
ENDPROC
DEF PROCpaletted
LOCAL bits%, hbm%, oldbm%, bmih{}
DIM bmih{Size%, Width%, Height%, Planes{l&,h&}, BitCount{l&,h&}, \
\ Compression%, SizeImage%, XPelsPerMeter%, YPelsPerMeter%, \
\ ClrUsed%, ClrImportant%}
bmih.Size% = DIM(bmih{})
bmih.Width% = @vdu%!208
bmih.Height% = @vdu%!212
bmih.Planes.l& = 1
bmih.BitCount.l& = 4
SYS "CreateDIBSection", @memhdc%, bmih{}, 0, ^bits%, 0, 0 TO hbm%
IF hbm% = 0 ERROR 100, "Couldn't create DIBSection"
SYS "SelectObject", @memhdc%, hbm% TO oldbm%
SYS "DeleteObject", oldbm%
PROCanimate
ENDPROC
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 23rd, 2015, 12:47pm
Avoid these two if you've consumed any LSD in the last hour or so:
Code: REM > NORDLYS
REM by Jan Vibe
REM Adapted for BB4W by DW
REMSYS"OS_UpdateMEMC",64,64
REMMODE12:ORIGIN 640,512:OFF
MODE 8 : ORIGIN 640,512 : OFF : PROCpaletted
DIM C1%(15),C2%(15),C3%(15),A%(4,2):N%=RND(-TIME):A%=0
FOR N%=1TO15
F1%=128*(SINRAD(24*N%)+1)
F2%=128*(SINRAD(24*N%+120)+1)
F3%=128*(SINRAD(24*N%+240)+1)
C1%(N%)=F1%:C2%(N%)=F2%:C3%(N%)=F3%
COLOUR N%,F1%,F2%,F3%
NEXT
REPEAT
FORN%=1TO2:FORM%=1TO4
A%(M%,N%)=RND(5)+1:NEXT,
FORN%=0TO270:T=RAD(N%/3)
X1=600*SIN(T*A%(1,1))*COS(T*A%(2,1))
Y1=500*SIN(T*A%(3,1))*COS(T*A%(4,1))
X2=600*SIN(T*A%(1,2))*COS(T*A%(2,2))
Y2=500*SIN(T*A%(3,2))*COS(T*A%(4,2))
ZX=(X2-X1)/28:ZY=(Y2-Y1)/28
FORI%=1TO15:C1%(I%-1)=C1%(I%):C2%(I%-1)=C2%(I%):C3%(I%-1)=C3%(I%)
NEXT:C1%(15)=C1%(0):C2%(15)=C2%(0):C3%(15)=C3%(0)
FORI%=1TO15:COLOURI%,C1%(I%),C2%(I%),C3%(I%):NEXT
PROCanimate : WAIT 1
A%=(A%+1)MOD15
FORM%=1TO15:GCOL 15-(M%+A%)MOD15
CIRCLE FILL X1,Y1,12:CIRCLE FILL X2,Y2,12
CIRCLE FILL -X1,Y1,12:CIRCLE FILL -X2,Y2,12
CIRCLE FILL -X1,-Y1,12:CIRCLE FILL -X2,-Y2,12
CIRCLE FILL X1,-Y1,12:CIRCLE FILL X2,-Y2,12
X1=X1+ZX:Y1=Y1+ZY:X2=X2-ZX:Y2=Y2-ZY
NEXT,
UNTIL0
REM The following code segment is from the
REM BB4W Programmer's Reference...
DEF PROCanimate
LOCAL C%, pal%()
DIM pal%(15)
SYS "GetPaletteEntries", @hpal%, 0, 16, ^pal%(0)
pal%() AND= &E0F0F0
FOR C% = 0 TO 15 : SWAP ?^pal%(C%), ?(2+^pal%(C%)) : NEXT
SYS "SetDIBColorTable", @memhdc%, 0, 16, ^pal%(0)
SYS "InvalidateRect", @hwnd%, 0, 0
ENDPROC
DEF PROCpaletted
LOCAL bits%, hbm%, oldbm%, bmih{}
DIM bmih{Size%, Width%, Height%, Planes{l&,h&}, BitCount{l&,h&}, \
\ Compression%, SizeImage%, XPelsPerMeter%, YPelsPerMeter%, \
\ ClrUsed%, ClrImportant%}
bmih.Size% = DIM(bmih{})
bmih.Width% = @vdu%!208
bmih.Height% = @vdu%!212
bmih.Planes.l& = 1
bmih.BitCount.l& = 4
SYS "CreateDIBSection", @memhdc%, bmih{}, 0, ^bits%, 0, 0 TO hbm%
IF hbm% = 0 ERROR 100, "Couldn't create DIBSection"
SYS "SelectObject", @memhdc%, hbm% TO oldbm%
SYS "DeleteObject", oldbm%
PROCanimate
ENDPROC
Code: REM > MATPAT
REM by Jan Vibe
REM Adapted for BB4W by DW
REM MODE9:OFF:ORIGIN 640,512
MODE 19 : OFF : ORIGIN 640,480 : PROCpaletted
DIMC1%(15),C2%(15),C3%(15)
FOR N%=1TO15
F1%=128*(SINRAD(24*N%)+1)
F2%=128*(SINRAD(24*N%+120)+1)
F3%=128*(SINRAD(24*N%+240)+1)
C1%(N%)=F1%:C2%(N%)=F2%:C3%(N%)=F3%
COLOUR N%,F1%,F2%,F3%
NEXT
FORB%=0TO128:Y%=B%*5
FORA%=B%TO160:X%=A%*5
GCOL(10*(COSRADX%+COSRADY%+SINRAD(SQR(X%*X%+Y%*Y%)*3)+3))MOD15+1
PLOT 4*A%,4*B%:PLOT -4*A%,4*B%:PLOT -4*A%,-4*B%:PLOT 4*A%,-4*B%
PLOT 4*B%,4*A%:PLOT -4*B%,4*A%:PLOT -4*B%,-4*A%:PLOT 4*B%,-4*A%
IF TIME>=3 THEN
FORI%=1TO15:C1%(I%-1)=C1%(I%):C2%(I%-1)=C2%(I%):C3%(I%-1)=C3%(I%)
NEXT:C1%(15)=C1%(0):C2%(15)=C2%(0):C3%(15)=C3%(0)
FORI%=1TO15:COLOURI%,C1%(I%),C2%(I%),C3%(I%):NEXT:PROCanimate:TIME=0
ENDIF
NEXT,
REPEAT
FORI%=1TO15:C1%(I%-1)=C1%(I%):C2%(I%-1)=C2%(I%):C3%(I%-1)=C3%(I%)
NEXT:C1%(15)=C1%(0):C2%(15)=C2%(0):C3%(15)=C3%(0)
FORI%=1TO15:COLOURI%,C1%(I%),C2%(I%),C3%(I%):NEXT
PROCanimate
K%=INKEY(3)
UNTIL0
REM The following code segment is from the
REM BB4W Programmer's Reference...
DEF PROCanimate
LOCAL C%, pal%()
DIM pal%(15)
SYS "GetPaletteEntries", @hpal%, 0, 16, ^pal%(0)
pal%() AND= &E0F0F0
FOR C% = 0 TO 15 : SWAP ?^pal%(C%), ?(2+^pal%(C%)) : NEXT
SYS "SetDIBColorTable", @memhdc%, 0, 16, ^pal%(0)
SYS "InvalidateRect", @hwnd%, 0, 0
ENDPROC
DEF PROCpaletted
LOCAL bits%, hbm%, oldbm%, bmih{}
DIM bmih{Size%, Width%, Height%, Planes{l&,h&}, BitCount{l&,h&}, \
\ Compression%, SizeImage%, XPelsPerMeter%, YPelsPerMeter%, \
\ ClrUsed%, ClrImportant%}
bmih.Size% = DIM(bmih{})
bmih.Width% = @vdu%!208
bmih.Height% = @vdu%!212
bmih.Planes.l& = 1
bmih.BitCount.l& = 4
SYS "CreateDIBSection", @memhdc%, bmih{}, 0, ^bits%, 0, 0 TO hbm%
IF hbm% = 0 ERROR 100, "Couldn't create DIBSection"
SYS "SelectObject", @memhdc%, hbm% TO oldbm%
SYS "DeleteObject", oldbm%
PROCanimate
ENDPROC
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 23rd, 2015, 2:27pm
Code: REM > ILD
REM by Jan Vibe
REM Adapted for BB4W by DW
REMMODE12:OFF
MODE 8 : OFF : PROCpaletted
DIMA%(4),C1%(15),C2%(15),C3%(15)
FORN%=1TO15
F1%=24*N%:F2%=F1%+120:F3%=F1%+240
C1%(N%)=128*(SINRADF1%+1)
C2%(N%)=128*(SINRADF2%+1)
C3%(N%)=128*(SINRADF3%+1)
COLOUR N%,C1%(N%),C2%(N%),C3%(N%)
NEXT
REPEAT
F%=1:R%=0
REPEAT:GCOL0,F%:F%=F%MOD15+1
@vdu%!248 = 2
FORN%=0TO8STEP2
CIRCLE640,512,R%+N%
CIRCLE640,510,R%+N%
IF TIME>=4 PROCS:TIME=0
NEXT:R%=R%+N%:UNTILR%>820
@vdu%!248 = 1
FORN%=1TO6
A%=RND(30)+20:Z=RND(1)+1:F%=RND(180)
FORX%=0TO1280STEP2:Y%=A%*SINRAD(X%*Z+F%)
RECTANGLE FILL X%,0,2,1022 TO X%,Y%
IF TIME>=4 PROCS:TIME=0
NEXT
A%=RND(30)+20:Z=RND(1)+1:F%=RND(180)
FORY%=0TO1024STEP4:X%=A%*SINRAD(Y%*Z+F%)
RECTANGLE FILL0,Y%,1280,2 TO X%,Y%
IF TIME>=4 PROCS:TIME=0
NEXT,
TIME=0
REPEAT
PROCS:K=INKEY(4)
UNTIL TIME>=3000
UNTIL0
DEFPROCS
LOCAL N%
C1%(0)=C1%(15):C2%(0)=C2%(15):C3%(0)=C3%(15)
FORN%=14TO0STEP-1
C1%(N%+1)=C1%(N%):C2%(N%+1)=C2%(N%):C3%(N%+1)=C3%(N%)
NEXT:FORN%=1TO15:COLOUR N%,C1%(N%),C2%(N%),C3%(N%):PROCanimate:NEXT
ENDPROC
REM The following code segment is from the
REM BB4W Programmer's Reference...
DEF PROCanimate
LOCAL C%, pal%()
DIM pal%(15)
SYS "GetPaletteEntries", @hpal%, 0, 16, ^pal%(0)
pal%() AND= &E0F0F0
FOR C% = 0 TO 15 : SWAP ?^pal%(C%), ?(2+^pal%(C%)) : NEXT
SYS "SetDIBColorTable", @memhdc%, 0, 16, ^pal%(0)
SYS "InvalidateRect", @hwnd%, 0, 0
ENDPROC
DEF PROCpaletted
LOCAL bits%, hbm%, oldbm%, bmih{}
DIM bmih{Size%, Width%, Height%, Planes{l&,h&}, BitCount{l&,h&}, \
\ Compression%, SizeImage%, XPelsPerMeter%, YPelsPerMeter%, \
\ ClrUsed%, ClrImportant%}
bmih.Size% = DIM(bmih{})
bmih.Width% = @vdu%!208
bmih.Height% = @vdu%!212
bmih.Planes.l& = 1
bmih.BitCount.l& = 4
SYS "CreateDIBSection", @memhdc%, bmih{}, 0, ^bits%, 0, 0 TO hbm%
IF hbm% = 0 ERROR 100, "Couldn't create DIBSection"
SYS "SelectObject", @memhdc%, hbm% TO oldbm%
SYS "DeleteObject", oldbm%
PROCanimate
ENDPROC
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 26th, 2015, 10:59pm
Not by Jan Vibe, but certainly inspired by one or two of his programs. It redraws (usually with a different colour scheme) every 10-or-so seconds.
Code:
REM>POLYWEB
REM by DW
REM Inspired by JV
REM Coded so as to be easily 'ported' to ARM BBC BASIC
MODE 10
OFF
ScrW% = @vdu%!208
ScrH% = @vdu%!212
Cx% = ScrW% DIV 2
Cy% = ScrH% DIV 2
MaxDist% = SQR(Cx%^2 + Cy%^2) + 0.5
NumCircs% = 150
MinSepDist% = 16
MaxSepDist% = 80
SepDiff% = MaxSepDist% - MinSepDist%
InitialRadius% = 100
DIM x%(NumCircs%-1), y%(NumCircs%-1)
DIM col%(NumCircs%-1, 2) : REM 0=R, 1=G, 2=B
R% = RND(-TIME)
REPEAT
swapRGB1% = RND(3)-1
swapRGB2% = RND(3)-1
swapRGB3% = RND(3)-1
swapRGB4% = RND(3)-1
invertR% = RND(2)-1
invertG% = RND(2)-1
invertB% = RND(2)-1
invertF% = RND(2)-1
x%(0) = RND( ScrW% )-1
y%(0) = RND( ScrH% )-1
PROCColour(0, FNdist(x%(0), y%(0))/MaxDist% )
FOR I% = 1 TO NumCircs%-1
REPEAT
x% = RND( ScrW% )-1
y% = RND( ScrH% )-1
dist0% = FNdist(x%, y%)
mindist% = MinSepDist% + dist0%/MaxDist%*SepDiff%
FOR J% = 0 TO I%-1
accept% = TRUE
d% = SQR((x% - x%(J%))^2 + (y% - y%(J%))^2)
IF d% < mindist% THEN
accept% = FALSE
J% = I%-1
ENDIF
NEXT J%
UNTIL accept%
x%(I%) = x%
y%(I%) = y%
PROCColour( I%, dist0%/MaxDist% )
NEXT I%
CLS
GCOL 15
FOR R% = InitialRadius% TO 1 STEP -1
FOR I% = 0 TO NumCircs%-1
COLOUR 15, col%(I%,0), col%(I%,1), col%(I%,2)
CIRCLE FILL 2*x%(I%), 2*y%(I%), 2*R%
NEXT I%
NEXT R%
WAIT 1000
UNTIL FALSE
END
DEF FNdist(X%, Y%)
= SQR((X% - Cx%)^2 + (Y% - Cy%)^2)
DEF PROCColour( K%, f )
IF invertF% THEN f = 1-f
col%(K%, 0) = f * RND(32)
col%(K%, 1) = f * (128 + RND(127))
col%(K%, 2) = f * RND(128)
IF invertR% THEN col%(K%,0) = 255 - col%(K%,0)
IF invertG% THEN col%(K%,1) = 255 - col%(K%,1)
IF invertB% THEN col%(K%,2) = 255 - col%(K%,2)
SWAP col%(K%, swapRGB1%), col%(K%, swapRGB2%)
SWAP col%(K%, swapRGB3%), col%(K%, swapRGB4%)
ENDPROC
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 27th, 2015, 4:03pm
Who needs multithreading when you've got TIMERLIB?
This works well on my laptop PC, with occasional hiccups:
Code:
REM>POLYWEB2
REM by DW
REM Inspired by JV
*FLOAT 64
*ESC OFF
MODE 10
OFF
BallSprPath$ = LEFT$(@lib$, LEN@lib$-4) + "EXAMPLES\GRAPHICS\BALL.ICO"
NumBalls% = 20
ScrW% = @vdu%!208
ScrH% = @vdu%!212
INSTALL @lib$ + "TIMERLIB"
INSTALL @lib$ + "NOWAIT"
INSTALL @lib$ + "SPRITELIB"
IF FN_initsprites( NumBalls% ) = 0 STOP
SprReady% = FALSE
timerid% = FN_ontimer(10, PROCUpdateBalls, 1)
ON CLOSE PROC_killtimer(timerid%) : PROC_exitsprites : QUIT
ON ERROR ON ERROR OFF : PROC_killtimer(timerid%) : PROC_exitsprites : OSCLI "REFRESH ON" : PRINT 'REPORT$ : END
FOR I% = 0 TO NumBalls%-1
IF FN_createsprite(I%, BallSprPath$, 32, 32) = 0 ERROR 0, "Cannot create sprite "+STR$I%
NEXT I%
SprReady% = TRUE
Cx% = ScrW% DIV 2
Cy% = ScrH% DIV 2
MaxDist% = SQR(Cx%^2 + Cy%^2) + 0.5
NumCircs% = 150
MinSepDist% = 16
MaxSepDist% = 80
SepDiff% = MaxSepDist% - MinSepDist%
InitialRadius% = 100
DIM x%(NumCircs%-1), y%(NumCircs%-1)
DIM col%(NumCircs%-1, 2) : REM 0=R, 1=G, 2=B
R% = RND(-TIME) : TIME = 0
REPEAT
swapRGB1% = RND(3)-1
swapRGB2% = RND(3)-1
swapRGB3% = RND(3)-1
swapRGB4% = RND(3)-1
invertR% = RND(2)-1
invertG% = RND(2)-1
invertB% = RND(2)-1
invertF% = RND(2)-1
x%(0) = RND( ScrW% )-1
y%(0) = RND( ScrH% )-1
PROCColour(0, FNdist(x%(0), y%(0))/MaxDist% )
FOR I% = 1 TO NumCircs%-1
REPEAT
x% = RND( ScrW% )-1
y% = RND( ScrH% )-1
dist0% = FNdist(x%, y%)
mindist% = MinSepDist% + dist0%/MaxDist%*SepDiff%
FOR J% = 0 TO I%-1
accept% = TRUE
d% = SQR((x% - x%(J%))^2 + (y% - y%(J%))^2)
IF d% < mindist% THEN
accept% = FALSE
J% = I%-1
ENDIF
NEXT J%
UNTIL accept%
x%(I%) = x%
y%(I%) = y%
PROCColour( I%, dist0%/MaxDist% )
NEXT I%
CLS
GCOL 15
FOR R% = InitialRadius% TO 1 STEP -1
FOR I% = 0 TO NumCircs%-1
COLOUR 15, col%(I%,0), col%(I%,1), col%(I%,2)
CIRCLE FILL 2*x%(I%), 2*y%(I%), 2*R%
NEXT I%
NEXT R%
PROCwait(500)
UNTIL FALSE
END
DEF FNdist(X%, Y%)
= SQR((X% - Cx%)^2 + (Y% - Cy%)^2)
DEF PROCColour( K%, f )
IF invertF% THEN f = 1-f
col%(K%, 0) = f * RND(32)
col%(K%, 1) = f * (128 + RND(127))
col%(K%, 2) = f * RND(128)
IF invertR% THEN col%(K%,0) = 255 - col%(K%,0)
IF invertG% THEN col%(K%,1) = 255 - col%(K%,1)
IF invertB% THEN col%(K%,2) = 255 - col%(K%,2)
SWAP col%(K%, swapRGB1%), col%(K%, swapRGB2%)
SWAP col%(K%, swapRGB3%), col%(K%, swapRGB4%)
ENDPROC
DEF PROCUpdateBalls
IF NOT SprReady% THEN ENDPROC
LOCAL I%, T%, X%, Y%, a, b, c, d, e, f
T% = TIME
FOR I% = 0 TO NumBalls%-1
a = T%/35 + I%/10
b = T%/92 + 0.3
c = T%/134 + 1.4
d = SIN(T%/200)
e = SIN(T%/50 + 2.1)*COS(T%/250 - 0.8)
f = SIN(T%/160 + I%/8)*COS(T%/123 + 1.4)
X% = 320*SIN(a + f)*SIN(b + d)*SIN(c + e)
Y% = 300*COS(a + f)*COS(b + d)*COS(c + e)
PROC_movesprite(I%, ScrW%+2*X%, ScrH%+2*Y%, 1)
NEXT I%
ENDPROC
Re: Some RISC OS graphical ditties converted to BB
Post by dfeugey on Nov 28th, 2015, 12:41pm
Cool...
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Nov 28th, 2015, 8:39pm
on Nov 28th, 2015, 12:41pm, dfeugey wrote:
I think it's time for an ARM BBC BASIC 'mega demo'. 
Ideally not touching assembly language (in order to keep it purely BASIC). Anyway, if one were to go ahead with it, I think the Raspberry Pi 2 would have to be the minimum requirement (the new Titanium sounds very nice, but I can't afford one!).
Perhaps a future Raspberry Pi 3 will feature an ARM Cortex-A15? That'd be nice, wouldn't it?
(Someone ought to suggest it to Eben.)
Some new additions to my website: http://www.proggies.uk
I intend to upload my old and more recent BB4W efforts over the next week or two.
David.
--
Re: Some RISC OS graphical ditties converted to BB
Post by dfeugey on Nov 29th, 2015, 06:47am
Yep, there is some room for a BBC Basic scene, because of the very fast two offers available (BBCBasic4Win and BBC Basic for RISC OS) and of the presence of interesting computers. On my todo list, I plan to recompile Brandy, with all the latest modifications, and perhaps even CGI management.
Re: Some RISC OS graphical ditties converted to BB
Post by DDRM on Dec 4th, 2015, 08:17am
Hi Folks,
Not really a reply, and not converted from RISC OS, but it seems to fit with the ongoing theme.
Here's a small ditty based on spirograph. Feel free to fiddle with it to your heart's content!
Code:
REM Spirograph simulation (epicycles). A smaller wheel (r2) rolls around inside a bigger one (r1)
MODE 21
ORIGIN 800,600
r1=500 :REM Radius of fixed circle
*REFRESH OFF
FOR denom%=3 TO 10
da2=denom% :REM Angle change in inner wheel between each plotted point, in degrees. You can use it like a speed control
CLS
FOR num%=1 TO denom%-1
r2=r1*num%/denom%
FOR pen=0.1 TO 0.9 STEP 0.01 :REM Distance of pen between centre and edge of smaller wheel
REM CLS:REM If you unREM this line you can see each individual pattern!
IF num% MOD 2=0 THEN p=1-pen ELSE p=pen
PROCDrawIt(0,r1,r2,p,da2,denom%,num%)
*REFRESH
NEXT pen
NEXT num%
NEXT denom%
*REFRESH ON
END
:
DEFPROCDrawIt(startangle,r1,r2,pen,da2,denom%,col%)
LOCAL da1,count%
da1=da2*r2/r1 :REM angle change around fixed circle for each "step" of moving wheel
GCOL col%
count%=0
MOVE (r1-r2)*COSRAD(startangle+da1*count%)+pen*r2*COSRAD(startangle-da2*count%),(r1-r2)*SINRAD(startangle+da1*count%)+pen*r2*SINRAD(startangle-da2*count%)
REPEAT
count%+=1
DRAW (r1-r2)*COSRAD(startangle+da1*count%)+pen*r2*COSRAD(startangle-da2*count%),(r1-r2)*SINRAD(startangle+da1*count%)+pen*r2*SINRAD(startangle-da2*count%)
UNTIL count%*da2>=360*denom%
ENDPROC
Best wishes,
D
Re: Some RISC OS graphical ditties converted to BB
Post by David Williams on Dec 4th, 2015, 7:08pm
Very nice, David.
Here's one inspired by a GIF animation I came across today whilst searching for something related:
http://www.i.imgur.com/Rnk6JvK.gif
(And here's what I was actually looking for: https://upload.wikimedia.org/wikipedia/commons/1/1a/Fourier_series_square_wave_circles_animation.gif)
Code:
REM>CIRCWAVES
REM Idea borrowed from an animated GIF found on Imgur via Reddit.com:
REM http://www.i.imgur.com/Rnk6JvK.gif
REM This BB4W version uses native graphics commands
*FLOAT 64
MODE 8
OFF
COLOUR 1, 64, 64, 64
COLOUR 2, 255, 255, 255
gap% = 2*32
radius% = 2*32
maxX% = (2*@vdu%!208 DIV gap%) + 1
maxY% = (2*@vdu%!212 DIV gap%) + 1
TIME = 0
*REFRESH OFF
REPEAT
CLS
REM Draw the circles first:
GCOL 1
FOR Y% = 0 TO maxY%
cy% = gap%*Y%
FOR X% = 0 TO maxX%
cx% = gap%*X%
CIRCLE cx%, cy%, radius%
NEXT X%
NEXT Y%
REM Now draw the moving points:
GCOL 2
T% = TIME * 2
I% = 0
FOR Y% = 0 TO maxY%
cy% = gap%*Y%
FOR X% = 0 TO maxX%
cx% = gap%*X%
px% = cx% + radius%*COSRAD(T% + I%)
py% = cy% + radius%*SINRAD(T% + I%)
CIRCLE FILL px%, py%, 8
I% += 15
NEXT X%
NEXT Y%
*REFRESH
UNTIL FALSE
EDIT: Which inevitably leads to something like this:
Code:
REM>CIRCWAVES2
*FLOAT 64
MODE 8
OFF
FOR I% = 1 TO 15
COLOUR I%, I%*255/16, I%*255/8, I%*255/4
NEXT I%
gap% = 2*16
radius% = 2*16
maxX% = (2*@vdu%!208 DIV gap%) + 1
maxY% = (2*@vdu%!212 DIV gap%) + 1
arraySz% = maxX% * maxY%
DIM grid%( arraySz%-1, 2 )
TIME = 0
*REFRESH OFF
REPEAT
CLS
I% = 0
T% = TIME
FOR Y% = 0 TO maxY%-1
cy% = gap%*Y%
FOR X% = 0 TO maxX%-1
cx% = gap%*X%
A% = T% + 8*I%
grid%(I%,0) = cx% + radius%*COSRADA%
grid%(I%,1) = cy% + radius%*SINRADA%
grid%(I%,2) = I% MOD 15
I% += 1
NEXT X%
NEXT Y%
FOR Y% = 0 TO maxY%-2
FOR X% = 0 TO maxX%-2
I% = Y%*maxX% + X%
GCOL grid%(I%,2)
MOVE grid%(I%,0), grid%(I%,1)
MOVE grid%(I%+1,0), grid%(I%+1,1)
PLOT 85, grid%(I%+maxX%,0), grid%(I%+maxX%,1)
PLOT 85, grid%(I%+maxX%+1,0), grid%(I%+maxX%+1,1)
NEXT X%
NEXT Y%
*REFRESH
UNTIL FALSE
Re: Some RISC OS graphical ditties converted to BB
Post by dfeugey on Dec 7th, 2015, 05:30am
A full pack of screensavers