These are fantastic!
1 Like
This one in particular is stunning!
Here’s a program that the manual says won’t work on LCDs. It does, though.
Option console serial
FRAMEBUFFER create
FRAMEBUFFER write f
CLS
'brownian motion demo using sprites
Dim integer x(32),y(32),c(32)
Dim float direction(32)
Dim integer i,j,k, collision=0
Dim string q$
For i=1 To 32
direction(i)=Rnd*360 'establish the starting direction For each atom
c(i)=RGB(Rnd*255,Rnd*255,Rnd*255) 'give each atom a colour
Circle 9,9,9,1,,RGB(white),c(i) 'draw the atom
Sprite read i,0,0,19,19 'read it in as a sprite
Next i
CLS RGB(myrtle)
Box 1,1,MM.HRES-2,MM.VRES-2
k=1
For i=MM.HRES\9 To MM.HRES\9*8 Step MM.HRES\9
For j=MM.VRES\9 To MM.VRES\9*8 Step MM.VRES\5
Sprite show k,i,j,1
x(k)=i
y(k)=j
vector k,direction(k), 0, x(k), y(k) 'load up the vector move
k=k+1
Next j
Next i
'
Do
For i=1 To 32
vector i, direction(i), 1, x(i), y(i)
Sprite show i,x(i),y(i),1
If sprite(S,i)<>-1 Then
break_collision i
EndIf
Next i
FRAMEBUFFER copy f,n
Print Timer:Timer =0
Loop
'
Sub vector(myobj As integer, angle As float, distance As float, x_new As integer, y_new As integer)
Static float y_move(32), x_move(32)
Static float x_last(32), y_last(32)
Static float last_angle(32)
If distance=0 Then
x_last(myobj)=x_new
y_last(myobj)=y_new
EndIf
If angle<>last_angle(myobj) Then
y_move(myobj)=-Cos(Rad(angle))
x_move(myobj)=Sin(Rad(angle))
last_angle(myobj)=angle
EndIf
x_last(myobj) = x_last(myobj) + distance * x_move(myobj)
y_last(myobj) = y_last(myobj) + distance * y_move(myobj)
x_new=Cint(x_last(myobj))
y_new=Cint(y_last(myobj))
Return
' keep doing stuff until we break the collisions
Sub break_collision(atom As integer)
Local integer j=1
Local float current_angle=direction(atom)
'start by a simple bounce to break the collision
If sprite(e,atom)=1 Then
'collision with left of screen
current_angle=360-current_angle
ElseIf sprite(e,atom)=2 Then
'collision with top of screen
current_angle=((540-current_angle) Mod 360 )
ElseIf sprite(e,atom)=4 Then
'collision with right of screen
current_angle=360-current_angle
ElseIf sprite(e,atom)=8 Then
'collision with bottom of screen
current_angle=((540-current_angle) Mod 360)
Else
'collision with another sprite or with a corner
current_angle = current_angle+180
EndIf
direction(atom)=current_angle
vector atom,direction(atom),j,x(atom),y(atom) 'break the collision
Sprite show atom,x(atom),y(atom),1
'if the simple bounce didn't work try a random bounce
Do While (sprite(t,atom) Or sprite(e,atom)) And j<10
Do
direction(atom)= Rnd*360
vector atom,direction(atom),j,x(atom),y(atom) 'break the collision
j=j+1
Loop Until x(atom)>=0 And x(atom)<=MM.HRES-sprite(w,atom) And y(atom)>=0 And y(atom)<=MM.VRES-sprite(h,atom)
Sprite show atom,x(atom),y(atom),1
Loop
' if that didn't work then place the atom randomly
Do While (sprite(t,atom) Or sprite(e,atom))
direction(atom)= Rnd*360
x(atom)=Rnd*(MM.HRES-sprite(w,atom))
y(atom)=Rnd*(MM.VRES-sprite(h,atom))
vector atom,direction(atom),0,x(atom),y(atom) 'break the collision
Sprite show atom,x(atom),y(atom),1
Loop
End Sub
1 Like
See also:
Originally posted by Peter on TheBackShed.
Also available in my attempt to collect interesting program examples here:
I’ll be updating the wiki shortly with a lot more stuff. Just need to finish a few more things with the local copy and then I can upload the new version.
"Lissajous” from TassyJim
Originally posted at CMM2 demo programs.
'Lissajous by Antoni Gual
' for Rel's 9 LINER contest at QBASICNEWS.COM 1/2003
' converted to MMBasic for the CMM2 by TassyJim May 2020
DIM col(15) ' GWBasic colours
col(0) = RGB(BLACK)
col(1) = RGB(BLUE)
col(2) = RGB(GREEN)
col(3) = RGB(CYAN)
col(4) = RGB(RED)
col(5) = RGB(MAGENTA)
col(6) = RGB(150, 75, 0) ' brown
col(7) = RGB(192,192,192) ' dull white
col(8) = RGB(127,127,127) ' grey
col(9) = RGB(173, 216, 230) ' light blue
col(10) = RGB(173, 216, 230)' light green
col(11) = RGB(144, 238, 144)' light cyan
col(12) = RGB(255, 100, 100)' light red
col(13) = RGB(255, 120, 255)' light magenta
col(14) = RGB(YELLOW) ' yellow
col(15) = RGB(WHITE) ' bright white
DIM INTEGER i , n
DIM FLOAT k,l,j
DO
CLS
i = (i + 1) AND &HFFFFF
k = 6.3 * RND()
l = 6.3 * RND()
n = (n + 1) MOD 15
FOR j = 0 TO 100000
PIXEL 320 * SIN(.01 * SIN(k) + j), 320 * SIN(.01 * SIN(l) * j), col(n + 1)
NEXT j
LOOP UNTIL INKEY$ <>""
1 Like
"ColourBars” from TassyJim
Note: This could be cleaned up quite a bit to only focus on the 320x320 PicoCalc display, but it serves as an example of aspect ratio changes that might be found on CMM2.
Originally posted at CMM2 demo programs.
'MMEDIT!!! Basic Version = CMM2
'MMEDIT!!! Port = COM7:115200:10,300
'MMEDIT!!! Device = CMM2
'MMEDIT!!! Config = 1001111011200100100200000100010
' test card for CMM2
' TassyJim May 2020
OPTION EXPLICIT
OPTION DEFAULT NONE
DIM INTEGER wd, ht, wbox, sh, x, w, n, nn, m
DIM FLOAT a
DIM k$, imgtitle$, fname$
dim integer unlocked ' enable all locked modes
DIM INTEGER c(8)
c(0) = RGB(BLACK)
c(1) = RGB(YELLOW)
c(2) = RGB(CYAN)
c(3) = RGB(GREEN)
c(4) = RGB(MAGENTA)
c(5) = RGB(RED)
c(6) = RGB(BLUE)
c(7) = RGB(WHITE)
c(8) = RGB(64,64,64)
cls
DO
SELECT CASE m
CASE 0
' do nothing
CASE 1
nn = 10
a = 1 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 1,8 Ratio "+str$(a,1,2)+" "
CASE 2
if unlocked = 1 then
nn = 10
a = 1 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 1,12 Ratio "+str$(a,1,2)+" "
endif
CASE 3
if unlocked = 1 then
nn = 10
a = 1 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 1,16 Ratio "+str$(a,1,2)+" "
endif
CASE 4
nn = 8
a = 1.08 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 2,8 Ratio "+str$(a,1,2)+" "
CASE 5
if unlocked = 1 then
nn = 8
a = 1.08 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 2,12 Ratio "+str$(a,1,2)+" "
endif
CASE 6
nn = 8
a = 1.08 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 2,16 Ratio "+str$(a,1,2)+" "
CASE 7
nn = 4
a = 1.08 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 3,8 Ratio "+str$(a,1,2)+" "
CASE 8
nn = 4
a = 1.08 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 3,12 Ratio "+str$(a,1,2)+" "
CASE 9
nn = 4
a = 1.08 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 3,16 Ratio "+str$(a,1,2)+" "
CASE 10
nn = 4
a = 0.833 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 4,8 Ratio "+str$(a,1,3)+" "
CASE 11
if unlocked = 1 then
nn = 4
a = 0.833 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 4,12 Ratio "+str$(a,1,3)+" "
endif
CASE 12
nn = 4
a = 0.833 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 4,16 Ratio "+str$(a,1,3)+" "
CASE 13
nn = 4
a = 0.833 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 5,8 Ratio "+str$(a,1,3)+" "
CASE 14
nn = 4
a = 0.833 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 5,12 Ratio "+str$(a,1,3)+" "
CASE 15
nn = 4
a = 0.833 ' aspect ratio used in the CIRCLE command.
imgtitle$ =" MODE 5,16 Ratio "+str$(a,1,3)+" "
END SELECT
'PRINT imgtitle$ ' for debug
if m = 0 then
cls
TEXT 160,100, "Video mode test",cm,1,1
TEXT 160,180, "Ratio refers to the aspect ratio",cm,1,1
TEXT 160,195, "used in the circle command",cm,1,1
TEXT 160,220, "Q to quit, P to save page as a BMP",cm,1,1
text 160,260, "UP arrow to go back,",cm,1,1
text 160,275, "any other key to advance",cm,1,1
text 160,285, "Do you want to test",cm,1,1
text 160,300, "the UNLOCKED modes? (Y/N)",cm,1,1
else
wd = MM.HRES : ht = MM.VRES
wbox = wd / 8
FOR x = 0 TO 7
BOX x*wbox,ht/4,wbox,ht/2,0,c(x), c(x)
NEXT x
FOR x = 0 TO wd-1
sh = 255*x/wd
LINE x,0,x,ht/12,1,RGB(sh,0,0)
LINE x,ht/12,x,ht/6,1,RGB(0,sh,0)
LINE x,ht/6,x,ht/4,1,RGB(0,0,sh)
LINE x,ht*9/12,x,ht*10/12,1,RGB(0,sh,sh)
LINE x,ht*10/12,x,ht*11/12,1,RGB(sh,0,sh)
LINE x,ht*11/12,x,ht,1,RGB(sh,sh,0)
LINE x,ht/2,x,ht*3/4,1,RGB(sh,sh,sh)
NEXT x
CIRCLE wd/2,ht/2, ht*15/32,3,a
sh = 0
x = wd/2 - 55*nn/2
FOR w = 10 TO 1 STEP -1
FOR n = 1 TO nn
sh = 255 - sh
LINE x,ht*3/8,x,ht*5/8,w,RGB(sh,sh,sh)
x = x + w
NEXT n
NEXT w
BOX 0,0,wd,ht,3,c(7)
BOX 1,1,wd-2,ht-2,1,c(5)
TEXT wd/2,ht/2, imgtitle$,cm,1,1
endif
DO
k$ = INKEY$
LOOP UNTIL k$<>""
if m = 0 and (k$ = "Y" OR k$ = "y") THEN
unlocked = 1
endif
IF k$ = "P" OR k$ = "p" THEN
fname$ = MID$(imgtitle$,2)+".bmp"
SAVE IMAGE fname$
TEXT wd/2,ht/2, "Saved as "+fname$,cm,1,1
DO
k$ = INKEY$
LOOP UNTIL k$<>""
ENDIF
IF k$ = "Q" OR k$ = "q" THEN EXIT DO
'PRINT ASC(k$)
IF ASC(k$) = 128 THEN
m = m - 1
if unlocked = 0 then ' skip locked modes
if m = 2 then m = 1
if m = 3 then m = 1
if m = 5 then m = 4
if m = 11 then m = 10
endif
IF m < 1 THEN m = 15
ELSE
m = m + 1
if unlocked = 0 then ' skip locked modes
if m = 2 then m = 4
if m = 3 then m = 4
if m = 5 then m = 6
if m = 11 then m = 12
endif
IF m > 15 THEN m = 1
ENDIF
LOOP
CLS
"Sudoku” from TassyJim
Originally posted at CMM2 demo programs.
'MMEDIT!!! Basic Version = CMM2
'MMEDIT!!! Port = COM7:115200:10,300
'MMEDIT!!! Device = CMM2
'MMEDIT!!! Config = 1001111011200100100200000100010
' Sudoku
' The section for solving is thanks to David Hall 2005
' and comes from QB64
' Converted to MMBasic for the CMM2 by TassyJim 2020
OPTION EXPLICIT
OPTION DEFAULT NONE
OPTION CONSOLE SERIAL 'prevent PRINT statements from messing up the screen
DIM gr$(18, 9), rg$(18, 9)
DIM seed$(9)
DIM AS INTEGER col(18,9)
DIM AS INTEGER sudoku(9,9)
DIM AS INTEGER gridH = MM.HRES/12 ' sized to suit different displays
DIM AS INTEGER gridV = MM.VRES/12
DIM AS INTEGER deltaH = gridH* 1.5
DIM AS INTEGER deltaV = 2
DIM AS INTEGER dH = gridH
DIM AS INTEGER dV = 2-gridV/2
DIM AS INTEGER fs = 1 ' font size
IF MM.HRES > 480 THEN fs = 3 ' use font 3 for high res
DIM AS INTEGER mLen = 48 ' max num of characters in messages.
DIM AS INTEGER x, y, vv, a, b, c, d, ct, co, mf, lf, fl
DIM AS INTEGER o, m, j, tc, v, w
DIM i$, p$
DIM AS INTEGER stopwatch, lc, hint
DIM AS INTEGER normal = 30, hard = 18, easy = 45 ' level of difficulty
DIM AS INTEGER preF = RGB(WHITE) ' colour of prefilled cells
DIM AS INTEGER blank = RGB(CYAN) ' colour of empty cells
DIM AS INTEGER user = RGB(GREEN) ' colour of user entry
DIM AS INTEGER computer = RGB(YELLOW) ' colour of computer solution
DIM AS INTEGER grid = RGB(GRAY) ' colour of grid
DIM AS INTEGER grid3 = RGB(WHITE) ' colour of grid
DIM AS INTEGER boxColour(3) ' colours for hi-lighting cells
boxColour(1) = RGB(GRAY)
boxColour(2) = RGB(RED)
boxColour(3) = RGB(MAGENTA)
startHere:
CLS
lc = 0
FOR a = 1 TO 18
FOR b = 1 TO 9
gr$(a, b) = " "
rg$(a, b) = ""
'col(a, b) = blank
NEXT b
NEXT a
drawGrid
message "1 = Easy, 2 = normal, 3 = hard",9
message "4 = manual, 9 = rerun, Q = Quit",10
do
i$ = inkey$
loop until i$<>""
select case i$
case "1"
x = prefill(easy)
case "2"
x = prefill(normal)
case "3"
x = prefill(hard)
case "4"
' leave empty
case "9"
reload
case "Q","q"
cls
end
case else
goto startHere
end select
FOR a = 1 TO 18
FOR b = 1 TO 9
if col(a, b) <> preF then
col(a, b) = blank
endif
NEXT b
NEXT a
message "CURSOR =move, 1-9 =number, ENTER =solve", 9
message "SPACE =clear cell, S =clear grid, H =hint", 10
x = 5: y = 5: vv = 1 ' start in the middle square
cc:
i$ = "?"' CHR$(2)
if gr$(x, y) <> " " THEN i$ = gr$(x, y)
drawdigit x,y, i$
currentBox(x,y,2)
i$ = ""
if hint then
message validDigits$(x,y),9
else
message "H to toggle hints",9
endif
message "CURSOR =move, 1-9 =number, ENTER =solve", 10
do
i$ = inkey$
loop until i$<>""
'print asc(i$)
DO : LOOP UNTIL INKEY$ = ""
select case i$
case "1","2","3","4","5","6","7","8","9" ' is a digit so enter it
if checkIt(x,y) = 0 then
gr$(x, y) = i$
col(x,y) = user
drawDigit x,y
else
flashCell
END IF
case " " ' space bar - clear cell
gr$(x, y) = " "
col(x, y) = blank
drawDigit x,y
case "H","h" ' toggle hint
hint = 1 - hint
case CHR$(13) 'enter - computer to solve the grid
message "'Deep Thought' in action",9
if quickCheck() = 0 then
message "Unable to solve from here!", 10
pause 5000
else
DO : LOOP UNTIL INKEY$ = ""
stopwatch = timer
GOTO solve
endif
case CHR$(130) ' left arrow
if x > 1 THEN
drawDigit x,y
x = x - 1
endif
case CHR$(131) ' right arrow
if x < 9 THEN
drawDigit x,y
x = x + 1
ENDIF
case CHR$(128) ' down arrow
if y > 1 THEN
drawDigit x,y
y = y - 1
Endif
case CHR$(129) ' up arrow
if y < 9 THEN
drawDigit x,y
y = y + 1
endif
case "Q","q"
cls
end
case "s","S" 'Start again
goto startHere
case ELSE
END select
if allFilled() then
message "It looks like you have done it!!",9
message "Press any key to go again",10
do
i$ = inkey$
loop until i$<>""
goto startHere
endif
GOTO cc
sub drawDigit(x as integer, y as integer, q$)' draw cell character or supplied character in q$
'print x,y
if q$ = "" then
text x * gridH+dH, y * gridV+dV,gr$(x, y),CM,2,1,col(x,y)
else
text x * gridH+dH, y * gridV+dV,q$,CM,2,1,col(x,y)
endif
currentBox(x,y,1)
end sub
sub currentBox( x as integer, y as integer,state as integer) ' draw a coloured box around the current cell
local integer tlX, tlY
tlX = x * gridH+dH-gridH/2
tlY = y * gridV+dV-gridV/2
drawGrid ' redraw full grid to erase any old cell highlighting
line tlX,tlY,tlX+gridH,tlY,1,boxColour(state)
line tlX,tlY,tlX,tlY+gridV,1,boxColour(state)
line tlX,tlY+gridV,tlX+gridH,tlY+gridV,1,boxColour(state)
line tlX+gridH,tlY,tlX+gridH,tlY+gridV,1,boxColour(state)
end sub
sub flashCell ' flash cell outline with invalid entry
local integer n
for n = 1 to 5
currentBox(x,y,3)
pause 100
currentBox(x,y,2)
pause 100
next n
end sub
sub drawGrid
local integer a
for a = 0 to 9
if a mod 3 = 0 then
line a*gridH+deltaH, deltaV, a*gridH+deltaH, 9*gridV+deltaV,1,grid3
line deltaH, a*gridV+deltaV, 9*gridH+deltaH, a*gridV+deltaV,1,grid3
else
line a*gridH+deltaH, deltaV, a*gridH+deltaH, 9*gridV+deltaV,1,grid
line deltaH, a*gridV+deltaV, 9*gridH+deltaH, a*gridV+deltaV,1,grid
endif
next a
end sub
function checkIt(x as integer,y as integer) as integer ' check that cell has valid digit
local integer a,b,c,d
checkIt = 0
a = 1
do WHILE a < 10
IF gr$(a, y) = i$ OR gr$(x, a) = i$ THEN
checkIt = 1
exit do
END IF
a = a + 1
loop
if checkIt = 0 then
a = ((x-1)\3)*3+1
b = ((y-1)\3)*3+1
FOR c = a TO a + 2
FOR d = b TO b + 2
IF gr$(c, d) = i$ THEN checkIt = 1
NEXT d
NEXT c
endif
end function
function validDigits$(x as integer,y as integer)' return all valid digits for current cell
local integer a,b,c,d,j, NA
if col(x,y) = preF then ' don't check prefilled cells
validDigits$ = "You can't change this cell "
else
validDigits$ = "Valid choices are : "
for j = 49 to 57
a = 1
NA = 0
do WHILE a < 10
IF gr$(a, y) = chr$(j) OR gr$(x, a) = chr$(j) THEN
NA = 1
exit do
END IF
a = a + 1
loop
if NA = 0 then
a = ((x-1)\3)*3+1
b = ((y-1)\3)*3+1
FOR c = a TO a + 2
FOR d = b TO b + 2
IF gr$(c, d) = chr$(j) THEN
NA = 1
exit for
endif
NEXT d
if NA = 1 then exit for
NEXT c
endif
if NA = 0 then validDigits$ = validDigits$ + chr$(j)+" "
next j
endif
end function
solve: ' solve it
p$ = inkey$
if p$<>"" then goto startHere
do
'print "1"
lf = 0: o = 49: a = 1: b = 1
FOR j = 49 TO 57
FOR y = 1 TO 9
FOR x = 1 TO 9
IF j = 49 THEN rg$(x, y) = ""
IF gr$(x, y) <> " " THEN continue for
i$ = CHR$(j)
gosub hh
IF fl = 0 THEN rg$(x, y) = rg$(x, y) + i$
IF j = 57 AND LEN(rg$(x, y)) = 1 THEN
gr$(x, y) = rg$(x, y)
col(x, y) = computer
drawDigit x,y
lf = 1
rg$(x, y) = ""
END IF
NEXT x
NEXT y
NEXT j
loop until lf <> 1
pip:
i$ = CHR$(o)
'print "2"
y = 1
do WHILE y < 10
ct = 0
FOR x = 1 TO 9
IF rg$(x, y) = "" THEN continue for
IF INSTR(1, rg$(x, y), i$) > 0 THEN
ct = ct + 1
v = x
END IF
NEXT x
IF ct = 1 THEN
x = v
gr$(x, y) = i$
col(x, y) = computer
drawDigit x,y
GOTO solve
END IF
y = y + 1
loop
x = 1
do WHILE x < 10
tc = 0
FOR y = 1 TO 9
IF rg$(x, y) = "" THEN continue for
IF INSTR(1, rg$(x, y), i$) > 0 THEN
tc = tc + 1
v = y
END IF
NEXT y
IF tc = 1 THEN
y = v
gr$(x, y) = i$
col(x, y) = computer
drawDigit x,y
GOTO solve
END IF
x = x + 1
loop
do WHILE b < 10
ct = 0
FOR c = a TO a + 2
FOR d = b TO b + 2
IF rg$(c, d) = "" THEN continue for
IF INSTR(1, rg$(c, d), i$) > 0 THEN
ct = ct + 1
v = c
w = d
END IF
NEXT d
NEXT c
IF ct = 1 THEN
x = v
y = w
gr$(x, y) = i$
col(x,y) = computer
drawDigit x,y
GOTO solve
END IF
a = a + 3
IF a > 7 THEN
a = 1
b = b + 3
END IF
loop
o = o + 1
IF o < 58 THEN GOTO pip
IF vv = 1 THEN
vv = 2
j = 0
m = 9
GOSUB kl
END IF
mf = 0
co = 0
FOR y = 1 TO 9
FOR x = 1 TO 9
i$ = gr$(x, y)
IF i$ = " " THEN
co = 1
continue for
END IF
gr$(x, y) = " "
if col(x,y) = blank then col(x,y) = computer
gosub hh 'fl = checkIt(x,y)
gr$(x, y) = i$
IF fl = 1 OR (gr$(x, y) = " " AND rg$(x, y) = "") THEN mf = 1
NEXT x
NEXT y
' print co,mf, lc 'DEBUG
refreshGrid
IF co = 0 AND mf = 0 THEN
print "Done! in "; (timer - stopwatch)/1000;" seconds" 'DEBUG
message "Completed! in "+str$((timer - stopwatch)/1000,4,1)+" sec",9
message "Press any key to go again",10
do
i$ = inkey$
loop until i$<>""
goto startHere
END IF
IF mf = 1 THEN
j = 9
m = 0
GOSUB kl
END IF
'lc = 0
rb:
x = INT(RND() * 9) + 1
y = INT(RND() * 9) + 1
lc = lc +1
' print "3"; 'DEBUG
if lc > 200 then
' print "OOPS!" 'DEBUG
message "Having difficulty!!!",9
goto solve
endif
IF LEN(rg$(x, y)) < 2 THEN GOTO rb
gr$(x, y) = MID$(rg$(x, y), INT(RND() * LEN(rg$(x, y))) + 1, 1)
GOTO solve
kl:
FOR y = 1 TO 9
FOR x = 1 TO 9
gr$(x + m, y) = gr$(x + j, y)
if gr$(x,y) = " " then col(x,y) = Blank
rg$(x + m, y) = rg$(x + j, y)
NEXT x
NEXT y
RETURN
hh:
fl = 0: a = 1
do WHILE a < 10
IF gr$(a, y) = i$ OR gr$(x, a) = i$ THEN
fl = 1
RETURN
END IF
a = a + 1
loop
a = ((x-1)\3)*3+1
b = ((y-1)\3)*3+1
FOR c = a TO a + 2
FOR d = b TO b + 2
IF gr$(c, d) = i$ THEN fl = 1
NEXT d
NEXT c
RETURN
sub refreshGrid ' redraw the display to clear out old computer guesses
local integer x,y
for x = 1 to 9
for y = 1 to 9
drawDigit x,y
next y
next x
drawgrid
end sub
function prefill(count as integer) as integer' setup a sudoku with chosen number of cells filled
local integer x,y,chosen
for x = 1 to 9
for y = 1 to 9
col(x,y) = blank
next y
next x
x = fillgrid()
do
x = int(rnd()*9+1)
y = int(rnd()*9+1)
if gr$(x,y) = " " then
gr$(x, y) = str$(sudoku(x,y))
col(x,y) = preF
drawDigit x,y
chosen = chosen + 1
endif
loop until chosen >= count
end function
sub reload ' start again with the same starting digits as previous run
local integer x,y
for x = 1 to 9
for y = 1 to 9
if col(x,y) = preF then
gr$(x, y) = str$(sudoku(x,y))
else
gr$(x, y) = " "
col(x,y) = blank
endif
drawDigit x,y
next y
next x
end sub
function fillgrid() as integer ' fills the grid based on the included digits.
'Rows and cols can be swapped within their group of 3 while remaining solvable.
local integer x, y, n, m, k, t, r
seed$(1) = "329657841"
seed$(2) = "745831296"
seed$(3) = "618249375"
seed$(4) = "193468527"
seed$(5) = "276195483"
seed$(6) = "854372619"
seed$(7) = "432716958"
seed$(8) = "587923164"
seed$(9) = "961584732"
for x = 1 to 9
for y = 1 to 9
sudoku(x,y) = val(mid$(seed$(x),y,1))
next y
next x
' ' print "Seed grid:" 'DEBUG
' ' r = printGrid() ' prints the seed grid for testing 'DEBUG
' ' print 'DEBUG
for r = 1 to 2
for k = 1 to 9 step 3 ' swap rows and columns within the group of 3
n = int(rnd()*3)
m = int(rnd()*3)
if m <> n then
for y = 1 to 9
t = sudoku(k+n,y)
sudoku(k+n,y) = sudoku(k+m,y)
sudoku(k+m,y) = t
next y
endif
n = int(rnd()*3)
m = int(rnd()*3)
if m <> n then
for x = 1 to 9
t = sudoku(x,k+n)
sudoku(x,k+n) = sudoku(x,k+m)
sudoku(x,k+m) = t
next x
endif
next k
n = int(rnd()*3) ' swap complete groups of 3 rows and columns
m = int(rnd()*3)
if m <> n then
for y = 1 to 9
for k = 1 to 3
t = sudoku(n*3+k,y)
sudoku(n*3+k,y) = sudoku(m*3+k,y)
sudoku(m*3+k,y) = t
next k
next y
endif
n = int(rnd()*3)
m = int(rnd()*3)
if m <> n then
for x = 1 to 9
for k = 1 to 3
t = sudoku(x,n*3+k)
sudoku(x,n*3+k) = sudoku(x,m*3+k)
sudoku(x,m*3+k) = t
next k
next x
endif
next r
end function
function printGrid() as integer ' prints the grid to console for debug
local integer x,y
for x = 1 to 9
for y = 1 to 9
print sudoku(x,y);" ";
next y
print
next x
end function
sub message(t$,l as integer) ' prints a message to line 1 to 10
local integer m
if len(t$) < mLen then ' pad the message to make sure we overwrite old message
m = (mLen - len(t$))/2
t$ = space$(m)+t$+space$(m)
endif
text gridH*6,gridV/2+gridV*l, t$,C,fs,1
end sub
function quickCheck() as integer' check for any cells that have no options
local integer x, y
quickCheck = 1
for x = 1 to 9
for y = 1 to 9
if gr$(x, y) = " " and validDigits$(x,y) = "Valid choices are : " then
quickCheck = 0
exit for
endif
next y
if quickCheck = 0 then exit for
next x
end function
function allFilled() as integer' check for any cells that are empty
local integer x, y
allFilled = 1
for x = 1 to 9
for y = 1 to 9
if gr$(x, y) = " " then
allFilled = 0
exit for
endif
next y
if allFilled = 0 then exit for
next x
end function
2 Likes
"Entropy displays the distribution of the hardware random number generator as a dynamic histogram.” from Sasquatch
Originally posted at CMM2 demo programs.
'Entropy.bas
Setup:
Dim A%(800)
XMax = MM.HRES - 1
YMax = MM.VRES - 1
Start:
CLS
Do
X = FIX(RND * XMax)
A%(X) = A%(X) + 1
Pixel X,YMAX - A%(X),RGB(WHITE)
Loop until A%(X) > YMax 'OR Inkey$ <> ""
Bug:
Line 112. “Flash” is a keyword, so you can’t use as a Subroutine name. Syntax error.
Good catch, thanks!
I fixed it by changing the Sub name to “flashCell” instead of “flash”. It’s odd that it worked on any version of MMBasic before, but maybe it was only tested on devices without flash, maybe there is/was an OPTION setting to allow for name collisions with reserved words, or maybe an older version of MMBasic wasn’t as good at enforcing reserved words.
In any case, it should work properly now. It’s a nice little Sudoku game and I think it’s well suited for the PicoCalc display and controls.
1 Like
"Circle One” from Volhout by way of the nicely ported and documented work of @thwill (thwill on TheBackShed) found at mmbasic-third-party GitHub repo. Apologies to thwill, as I basically hacked together a single source file (since PicoCalc’s PicoMite doesn’t support #include) by cobbling together bits and pieces of all the nicely organized code at that repo, and completely abandoned the portability aspect to keep the code size down. I’m sure it could be optimized further, but this seems to work.
Originally posted at Game*Mite: handheld game console based on PicoMite.
WARNING: this code will not run as-is, unless you first run the following command:
OPTION MODBUFF ENABLE
This will cause a reboot.
You’ll also need to download circle.mod and save it in the same place as your basic source file.
By default, PicoMite/WebMite doesn’t create a buffer in flash for playing MOD files. And since this game uses a MOD file for background music, those commands will fail with an error if you haven’t set up the buffer. Optionally, you can just comment out or delete the
Play ModFile ... and PLAY STOP lines in the code, and skip the music altogether.
NOTE: Controls are a bit wonky. It might even make sense to remap some of them. I’m curious about other’s thoughts on sane defaults for these sorts of gaming controls that could be applied to future games. Some games also use a “B” button along with “A”. The PicoCalc keyboard layout doesn’t seem to have obvious mapping that could be used. On the one hand, Enter could be used for “START”, Esc for “HOME”, and Space for “SELECT”, but where should the “A” and “B” button go? Multiple keys could be mapped to the same “controller button”, so maybe F1-F5 could be mapped to “HOME”, “START”, “SELECT”, “A”, and “B” and then other keys used as well. I’m open to suggestions!
For now, based on the original code keyboard mappings:
| PicoCalc key | Game*Mite key (on intro screen) | Game function |
|---|---|---|
| SPACE or X | A | sprint / ok |
| A | SELECT | quit |
| S | START | play / pause |
| UP | UP | up |
| DOWN | DOWN | down |
| LEFT | LEFT | left |
| RIGHT | RIGHT | right |
| ESC | HOME | quit |
'_Circle-One for Game*Mite (PicoMite 5.08.00)
' Copyright (c) 2023-2024 @Volhout
' Titivated for Game*Mite by Thomas Hugo Williams
Option Base 0
Option Default Float
Option Explicit On
Const VERSION = 101302 ' 1.1.2
Dim sys.break_flag%
' Formats an integer version as a string.
'
' @param v% version number: AABBCDD
' - AA is the 2-digit major version.
' - BB is the 2-digit minor version.
' - C = 0 for alpha
' = 1 for beta
' = 2 for release candidate
' = 3..9 for release.
' - DD is the micro version if c <= 3.
' If c > 3 Then CDD - 300 is the micro version.
Function sys.format_version$(v%)
Const v_% = Choice(v%, v%, sys.VERSION)
Local s$ = Str$(v_%\10^5) + "." + Str$((v_% Mod 10^5) \ 10^3)
Select Case v_% Mod 1000
Case < 100 : Cat s$, " alpha " + Str$(v_% Mod 1000)
Case < 200 : Cat s$, " beta " + Str$((v_% Mod 1000) - 100)
Case < 300 : Cat s$, " RC " + Str$((v_% Mod 1000) - 200)
Case Else : Cat s$, "." + Str$((v_% Mod 1000) - 300)
End Select
sys.format_version$ = s$
End Function
' Overrides Ctrl-C behaviour such that:
' - Ctrl-C will call sys.break_handler()
' - Ctrl-D will perform an actual MMBasic break
Sub sys.override_break(callback$)
sys.break_flag% = 0
Option Break 4
If Len(callback$) Then
Execute "On Key 3, " + callback$ + "()"
Else
On Key 3, sys.break_handler()
EndIf
End Sub
' Called as an ON KEY interrupt when Ctrl-C is overridden by sys.override_break().
' Increments the sys.break_flag%, if the flag is then > 1 then END the program.
Sub sys.break_handler()
Inc sys.break_flag%
If sys.break_flag% > 1 Then
sys.restore_break()
End
EndIf
End Sub
' Restores default Ctrl-C behaviour.
Sub sys.restore_break()
sys.break_flag% = 0
On Key 3, 0
Option Break 3
End Sub
Const ctrl.UI_DELAY = 200 ' 200 micro-seconds.
' Button values as returned by controller driver subroutines.
Const ctrl.R = &h01
Const ctrl.START = &h02
Const ctrl.HOME = &h04
Const ctrl.SELECT = &h08
Const ctrl.L = &h10
Const ctrl.DOWN = &h20
Const ctrl.RIGHT = &h40
Const ctrl.UP = &h80
Const ctrl.LEFT = &h100
Const ctrl.ZR = &h200
Const ctrl.X = &h400
Const ctrl.A = &h800
Const ctrl.Y = &h1000
Const ctrl.B = &h2000
Const ctrl.ZL = &h4000
' When a key is down the corresponding byte of this 256-byte map is set,
' when the key is up then it is unset.
'
' Note that when using INKEY$ (as opposed to the CMM2 'KEYDOWN' function or
' the PicoMiteVGA 'ON PS2' command) to read the keyboard we cannot detect
' keyup events and instead automatically clear a byte after it is read.
Dim ctrl.key_map%(31 + Mm.Info(Option Base))
' Gets a default controller driver based on the current platform.
Function ctrl.default_driver$()
ctrl.default_driver$ = "keys_cursor_ext"
End Function
' Initialises keyboard reading.
'
' @param use_inkey% Use INKEY$ even on platforms with KEYDOWN or ON PS2.
' @param period% CMM2 only, interval to read KEYDOWN state, default 40 ms.
' @param nbr% CMM2 only, timer nbr to read KEYDOWN state, default 4.
Sub ctrl.init_keys(use_inkey%, period%, nbr%)
ctrl.term_keys()
On Key ctrl.on_key()
End Sub
' TODO: use the 'lower-case' character for all keys, not just letters.
Sub ctrl.on_key()
Poke Var ctrl.key_map%(), Asc(LCase$(Inkey$)), 1
End Sub
' Terminates keyboard reading.
Sub ctrl.term_keys()
On Key 0
Memory Set Peek(VarAddr ctrl.key_map%()), 0, 256
Do While Inkey$ <> "" : Loop
End Sub
Function ctrl.keydown%(i%)
ctrl.keydown% = Peek(Var ctrl.key_map%(), i%)
Poke Var ctrl.key_map%(), i%, 0
End Function
Sub keys_cursor_ext(x%)
If x% < 0 Then Exit Sub
x% = (ctrl.keydown%(32) Or ctrl.keydown%(120)) * ctrl.A ' Space or X
Inc x%, ctrl.keydown%(122) * ctrl.B ' Z
Inc x%, (ctrl.keydown%(&hA) Or ctrl.keydown%(97)) * ctrl.SELECT ' Enter or A
Inc x%, ctrl.keydown%(115) * ctrl.START ' S
Inc x%, ctrl.keydown%(128) * ctrl.UP
Inc x%, ctrl.keydown%(129) * ctrl.DOWN
Inc x%, ctrl.keydown%(130) * ctrl.LEFT
Inc x%, ctrl.keydown%(131) * ctrl.RIGHT
Inc x%, ctrl.keydown%(27) * ctrl.HOME ' Escape
End Sub
' Common code for cleaning up and returning to any shell program after a game
' ends. Note that it is possible that much of this is (now) unnecessary due to
' improvements in how MMBasic handles the cleanup itself on calling END or RUN.
'
' @param break% If 0 then this is a "normal" end, if 1 then it is the result
' of Ctrl-C. In the current version of this subroutine this
' does not have an effect on behaviour.
Sub game.end(break%)
FrameBuffer Write N
FrameBuffer Close
Colour Rgb(White), Rgb(Black)
If Mm.HRes = 320 Then Font 7 Else Font 1
Cls
sys.restore_break()
' Use ON ERROR SKIP because we might not be using these libraries.
On Error Skip : sound.term()
On Error Skip : ctrl.term()
SetTick 0,0,1 : SetTick 0,0,2 : SetTick 0,0,3 : SetTick 0,0,4
Play Stop
' For the moment always return to shell/menu if available.
break% = 0
Local msg$
If break% Then
msg$ = "Exited due to Ctrl-C"
ElseIf InStr(Mm.CmdLine$, "--shell") Then
msg$ = "Loading menu ..."
EndIf
If msg$ <> "" Then
Text Mm.HRes / 2, Mm.VRes / 2, msg$, CM
EndIf
' TODO: twm.term() should subsume twm.free() and also do this.
On Error Skip : twm.enable_cursor(1)
If Not break% And InStr(Mm.CmdLine$, "--shell") Then sys.run_shell()
End
End Sub
Sub game.on_break()
game.end(1)
End Sub
Const msgbox.NO_PAGES = &h01
Dim msgbox.buffer% = 64
Function msgbox.show%(x%, y%, w%, h%, msg$, buttons$(), default%, ctrl$, fg%, bg%, frame%, flags%)
Const base% = Mm.Info(Option Base), num% = Bound(buttons$(), 1) - base% + 1
Local i%, btn_x%(num%), p% = 1
btn_x%(base%) = x% + 2
For i% = base% + 1 To base% + num% - 1
btn_x%(i%) = btn_x%(i% - 1) + Len(buttons$(i% - 1)) + 5
Next
' Backup display.
Const fh% = Mm.Info(FontHeight), fw% = Mm.Info(FontWidth)
Blit Read msgbox.buffer%, x% * fw%, y% * fh%, w% * fw%, h% * fh%
msgbox.box(x%, y%, w%, h%, 1, Choice(frame% = -1, fg%, frame%), bg%)
i% = y% + 2
Do While p% <= Len(msg$)
msgbox.print_at(x% + 2, i%, str.wwrap$(msg$, p%, w% - 4), fg%, bg%)
Inc i%
Loop
Local key%, released%, valid% = 1
msgbox.show% = default%
Do
If sys.break_flag% Then msgbox.show% = default% : Exit Function
If valid% Then
For i% = base% To base% + num% - 1
msgbox.button(btn_x%(i%), y% + h% - 4, buttons$(i%), i% = msgbox.show%, fg%, bg%)
Next
If Not flags% And msgbox.NO_PAGES Then
FrameBuffer Copy F, N
EndIf
valid% = 0
EndIf
Call ctrl$, key%
If Not key% Then keys_cursor_ext(key%)
If Not key% Then released% = 1 : Continue Do
If Not released% Then key% = 0 : Continue Do
valid% = 0
Select Case key%
Case ctrl.A, ctrl.SELECT
key% = ctrl.SELECT
valid% = 1
Case ctrl.LEFT
If msgbox.show% > 0 Then Inc msgbox.show%, -1 : valid% =1
Case ctrl.RIGHT
If msgbox.show% < num% - 1 Then Inc msgbox.show% : valid% =1
End Select
msgbox.beep(valid%)
Pause ctrl.UI_DELAY - 100
Loop Until key% = ctrl.SELECT
' Restore display.
Blit Write msgbox.buffer%, x% * fw%, y% * fh%
Blit Close msgbox.buffer%
If Not flags% And msgbox.NO_PAGES Then
FrameBuffer Copy F, N
EndIf
End Function
Sub msgbox.button(x%, y%, txt$, selected%, fg%, bg%)
msgbox.box(x%, y%, Len(txt$) + 4, 3, 0, fg%, -1)
Const fg_% = Choice(selected%, bg%, fg%)
Const bg_% = Choice(selected%, fg%, bg%)
msgbox.print_at(x% + 2, y% + 1, txt$, fg_%, bg_%)
End Sub
Sub msgbox.box(x%, y%, w%, h%, dbl%, fg%, bg%)
Const fh% = Mm.Info(FontHeight), fw% = Mm.Info(FontWidth)
Local d% = fw% \ 2
If bg% >= 0 Then Box x% * fw%, y% * fh%, w% * fw%, h% * fh%, , bg%, bg%
Box x% * fw% + d%, y% * fh% + d%, w% * fw% - 2 * d%, h% * fh% - 2 * d%, 1, fg%
Inc d%, d%
If dbl% Then Box x% * fw% + d%, y% * fh% + d%, w% * fw% - 2 * d%, h% * fh% - 2 * d%, 1, fg%
End Sub
Sub msgbox.print_at(x%, y%, s$, fg%, bg%)
Text x% * Mm.Info(FontWidth), y% * Mm.Info(FontHeight), s$, , , , fg%, bg%
End Sub
Sub msgbox.beep(valid%)
' These are the same frequencies as for the sound.BLART and sound.SELECT effects.
If valid% Then
' Local notes!(3) = (493.88, 783.99, 987.77, 0.0) ' B4,G5,B5,-
Local notes!(3) = (987.77, 1567.98, 1975.53, 30.87) ' B5,G6,B6,-
Else
' Local notes!(3) = (523.25, 493.88, 369.99, 349.23) ' C5,B4,F#4,F4
Local notes!(4) = (1046.50, 987.77, 739.99, 698.46, 30.87) ' C6,B5,F#5,F5,-
EndIf
Play Stop
Pause 10 ' The PAUSE helps to suppress an (MMB4L specific?) audio glitch.
Local i%
For i% = Bound(notes!(), 0) To Bound(notes!(), 1)
If notes!(i%) > 16.0 Then Play Sound 4, B, S, notes!(i%), 25
Pause 40
Next
Play Stop
End Sub
' Implements word wrapping by splitting a string on spaces.
'
' @param[in] s$ the string.
' @param[in, out] p% position in the string to start from.
' @param[in] len% the 'line length'.
' @return segment of string up to len% characters with no broken
' words, unless a word is longer than len%.
Function str.wwrap$(s$, p%, len%)
Const slen% = Len(s$)
Local ch%, q%, word$
For q% = p% To slen% + 1
ch% = Choice(q% > slen%, 0, Peek(Var s$, q%))
Select Case ch%
Case 0, &h0A, &h0D, &h20 ' null, \n, \r, space
If Len(str.wwrap$) + Len(word$) > len% Then
If Len(word$) > len% Then
word$ = Left$(word$, len% - Len(str.wwrap$))
Cat str.wwrap$, word$
Inc p%, Len(word$)
EndIf
Exit For
EndIf
Cat str.wwrap$, word$
p% = q% + 1
Select Case ch%
Case &h0D
If Choice(p% > slen%, 0, Peek(Var s$, p%)) = &h0A Then Inc p%
Exit For
Case &h20
If Len(str.wwrap$) = len% Then Exit For
Cat str.wwrap$, " "
word$ = ""
Case Else
Exit For
End Select
Case Else
Cat word$, Chr$(ch%)
End Select
Next
p% = Min(p%, slen% + 1)
End Function
sys.override_break("on_break")
Const CURRENT_PATH$ = Choice(Mm.Info(Path) <> "NONE", Mm.Info(Path), Cwd$)
Const CB = Rgb(Blue), CC= Rgb(Cyan), CG = Rgb(Green)
Const CR = Rgb(Red), CW = Rgb(White), CY = Rgb(Yellow)
Const VERSION_STRING$ = "Game*Mite Version " + sys.format_version$(VERSION)
Const STATE_SHOW_TITLE = 0, STATE_PLAY_GAME = 1
' Index 0 is food, 1 is player 1, 2 is player 2
Dim c(2) ' Colour
Dim dx(2), dy(2) ' Direction of movement in x & y directions
Dim pause_flag% ' = 1 then pause the game
Dim p(2) As Integer ' Player input; bitset of ctrl.DOWN|LEFT|RIGHT|UP
Dim r(2) ' Radius
Dim s(2) ' Speed
Dim score(2)
Dim t%
Dim v(2) ' > 0 if player moving
Dim x(2), y(2) ' Coordinates
Dim state%
' Initialise input
ctrl.init_keys()
Dim ctrl$ = ctrl.default_driver$()
' Game music
Play ModFile CURRENT_PATH$ + "circle.mod"
' The game uses the FrameBuffer to prevent screen drawing artifacts
FrameBuffer Create
FrameBuffer Write F
Font 8
Do
state% = STATE_SHOW_TITLE
show_intro()
state% = STATE_PLAY_GAME
score(1) = 0 : score(2) = 0
start_round()
Do While state% <> STATE_SHOW_TITLE
t% = Timer + 100
If Not c(0) Then create_food()
If c(0) Then draw_food(c(0))
ctrl_player()
ctrl_ai()
erase_players()
move_players()
handle_collisions()
draw_players()
handle_winning()
draw_score()
If pause_flag% Then handle_pause()
FrameBuffer Copy F, N
Do While Timer < t% : Loop
Loop
Loop
Error "Unexpected program end"
Sub on_quit()
msgbox.beep(1)
Const fg% = Rgb(White), bg% = Rgb(Black), frame% = Rgb(Rust), flags% = &h0
If state% = STATE_SHOW_TITLE Then
Local buttons$(1) Length 3 = ("Yes", "No")
Const msg$ = "Quit game?"
Const x% = 9, y% = 10, w% = 22, h% = 9, btn% = 1
Else
Local buttons$(2) Length 7 = ("Restart", "Quit", "Cancel")
Const msg$ = "Restart or Quit?"
Const x% = 2, y% = 10, w% = 36, h% = 9, btn% = 2
EndIf
Const answer% = msgbox.show%(x%,y%,w%,h%,msg$,buttons$(),btn%,ctrl$,fg%,bg%,frame%,flags%)
Select Case buttons$(answer%)
Case "Quit", "Yes" : end_program()
Case "Restart" : state% = STATE_SHOW_TITLE
End Select
Play ModFile CURRENT_PATH$ + "circle.mod"
End Sub
'!dynamic_call on_break
Sub on_break()
end_program(1)
End Sub
Sub end_program(break%)
If Not break% Then
Cls
Text Mm.HRes / 2, Mm.VRes / 2 - 10, "Bye!", "CM", 8, 2, CY
FrameBuffer Copy F, N
Pause 2000
EndIf
game.end(break%)
End Sub
Sub show_intro()
Cls
Const key% = display_text%("intro_data", Mm.VRes / 2 - 80, 1000)
End Sub
intro_data:
Data "CIRCLE ONE", 2, CY, 17
Data "2023-2024 @Volhout", 1, CC, 13
Data "<version>", 1, CG, 17
Data "", 1, CW, 17
Data "Eat apples to grow and win", 1, CW, 17
Data "Use arrow keys to steer", 1, CW, 17
Data "A to sprint, START to pause", 1, CW, 17
Data "Avoid collisions !!", 1, CW, 17
Data "", 1, CW, 17
Data "Press START to play", 1, CY, 17
Data "or SELECT to quit", 1, CY, 17
Data "", 0, 0, 0
' Reads and displays text from DATA statements
'
' @param label$ Label for the DATA to read
' @param top% Initial y-coordinate
' @param msec% Pause duration between showing each line of text
' @return the controller code for the key/button pressed
Function display_text%(label$, top%, msec%)
Local col%, dy%, h%, s$, sz%, t%, w%, y% = top%
Local k% = Not msec%
Local k_old% = get_input%()
Restore label$
Do
Read s$, sz%, col%, dy%
If Not sz% Then Exit Do
If s$ = "<version>" Then s$ = VERSION_STRING$
w% = Len(s$) * 8 * sz% + 4
h% = 8 * sz% + 4
If Len(s$) Then Box (Mm.HRes - w%) / 2, y% - h% / 2, w%, h%, 1, 0, 0
Text Mm.HRes / 2, y%, s$, "CM", 8, sz%, col% : Inc y%, dy%
If k% Then Continue Do ' Pressing a key interrupts the PAUSE-ing.
FrameBuffer Wait
FrameBuffer Copy F, N
t% = Timer + msec%
Do While (Timer < t%) And (Not k%)
k% = get_input%()
' Require the user to have released key or be pressing different key.
If k% = k_old% Then k% = 0 Else k_old% = k%
Loop
Loop
FrameBuffer Wait
FrameBuffer Copy F, N
Do While get_input%(1) : Loop
Do While Not(get_input%() And (ctrl.START Or ctrl.A)) : Loop
Do While get_input%(1) : Loop
End Function
Function get_input%(ignore%)
Call ctrl$, get_input%
If Not get_input% Then keys_cursor_ext(get_input%)
If ignore% Then Exit Function
Select Case get_input%
Case ctrl.HOME, ctrl.SELECT
on_quit()
get_input% = 0
End Select
End Function
Sub start_round()
Cls
Const SIZE = Mm.HRes / 40
x(0) = Mm.HRes / 2 : y(0) = Mm.VRes / 3 : r(0) = SIZE : c(0) = CG
x(1) = Mm.HRes / 3 : y(1) = 2 * Mm.VRes / 3 : r(1) = SIZE : c(1) = CB : s(1) = 5 'player speed, tweak
x(2) = 2 * Mm.HRes / 3 : y(2) = 2 * Mm.VRes / 3 : r(2) = SIZE : c(2) = CR : s(2) = 3 'AI speed, tweak
End Sub
' Creates new food in a random location. If the result is too
' close to a player then do not create food on this call.
Sub create_food()
x(0) = Mm.HRes * Rnd()
y(0) = Mm.VRes * Rnd()
Const d10 = Sqr((x(1) - x(0)) ^ 2 + (y(1) - y(0)) ^ 2)
Const d20 = Sqr((x(2) - x(0)) ^ 2 + (y(2) - y(0)) ^ 2)
If d10 < (r(1) + r(0) + 20) Then Exit Sub
If d20 < (r(0) + r(2) + 20) Then Exit Sub
c(0) = CG
End Sub
Sub draw_food(c%)
Circle x(0) - 4, y(0) - 2, r(0), , , c%, c%
Circle x(0) + 4, y(0), r(0), , , c%, c%
Line x(0) - 3, y(0), x(0) + 5, y(0) - 2 * r(0), 1, c%
End Sub
Sub ctrl_player()
Const p_old% = p(1)
Const key% = get_input%()
p(1) = key% And (ctrl.DOWN Or ctrl.LEFT Or ctrl.RIGHT Or ctrl.UP)
If key% And ctrl.A Then s(1) = 12 ' Turbo run, tweak for fun
If key% And ctrl.START Then pause_flag% = 1
If Not p(1) Then p(1) = p_old%
If s(1) > 5 Then Inc s(1), -1 ' Slow player if turbo-running
End Sub
Sub ctrl_ai()
Local AIx% = Int((x(0) - x(2)) / 2), AIy% = Int((y(0) - y(2)) / 2)
p(2) = 0
If Abs(AIx%) > 1 Then p(2) = p(2) Or Choice(AIx% < 0, ctrl.LEFT, ctrl.RIGHT)
If Abs(AIy%) > 1 Then p(2) = p(2) Or Choice(AIy% < 0, ctrl.UP, ctrl.DOWN)
End Sub
Sub erase_players()
Local i%
For i% = 1 To 2
Circle x(i%), y(i%), r(i%) + 10, , , 0, 0
Next
End Sub
Sub move_players()
Local i%
For i% = 1 To 2
v(i%) = 0 : dx(i%) = 0 : dy(i%) = 0
If p(i%) And ctrl.LEFT Then Inc v(i%) : Inc x(i%), -s(i%) : dx(i%) = -1
If p(i%) And ctrl.RIGHT Then Inc v(i%) : Inc x(i%), s(i%) : dx(i%) = 1
If p(i%) And ctrl.UP Then Inc v(i%) : Inc y(i%), -s(i%) : dy(i%) = -1
If p(i%) And ctrl.DOWN Then Inc v(i%) : Inc y(i%), s(i%) : dy(i%) = 1
' Allow wrap around
Inc x(i%), Choice(x(i%) < 0, Mm.HRes, Choice(x(i%) > Mm.HRes, -Mm.HRes, 0))
Inc y(i%), Choice(y(i%) < 0, Mm.VRes, Choice(y(i%) > Mm.VRes, -Mm.VRes, 0))
Next
End Sub
Sub handle_collisions()
' Calculate distances
Const d12 = Sqr((x(1) - x(2)) ^ 2 + (y(1) - y(2)) ^ 2)
Const d10 = Sqr((x(1) - x(0)) ^ 2 + (y(1) - y(0)) ^ 2)
Const d20 = Sqr((x(2) - x(0)) ^ 2 + (y(2) - y(0)) ^ 2)
' Game rules:
' - collision between players is punished
' - player who moves is culprit
If d12 < (r(1) + r(2)) Then
If v(1) > 0 Then r(1) = r(1) / 1.5
If v(2) > 0 Then r(2) = r(2) / 1.5
r(1) = Max(r(1), 3)
r(2) = Max(r(2), 3)
EndIf
' You eat, you grow
If c(0) Then
If d10 < (r(1) + r(0)) Then eat_food(1)
If d20 < (r(0) + r(2)) Then eat_food(2)
EndIf
End Sub
Sub eat_food(p%)
r(p%) = r(p%) * 2
draw_food(0)
c(0) = 0
End Sub
Sub draw_players()
Static counter% = 0
Local i%, dyy, dxx, vv
Inc counter%, 1
For i% = 1 To 2
' Draw body
Circle x(i%), y(i%), r(i%), , , c(i%), c(i%)
If v(i%) > 0 Then
' Draw eyes when moving
vv = 0.7 + (v(i%) = 1) * 0.3 'sqrt 2 if 45 degrees
dyy = 6 * dy(i%) : dxx = 6 * dx(i%)
draw_circle(x(i%) + vv * ((dx(i%) * r(i%)) - dyy), y(i%) + vv * ((dy(i%) * r(i%)) + dxx), 5, CW)
draw_circle(x(i%) + vv * ((dx(i%) * r(i%)) + dyy), y(i%) + vv * ((dy(i%) * r(i%)) - dxx), 5, CW)
draw_circle(x(i%) + vv * ((dx(i%) * (r(i%) + 2) - dyy)), y(i%) + vv * ((dy(i%) * (r(i%) + 2)) + dxx), 2)
draw_circle(x(i%) + vv * ((dx(i%) * (r(i%) + 2) + dyy)), y(i%) + vv * ((dy(i%) * (r(i%) + 2)) - dxx), 2)
Else
' Draw eyes when sleepy
Circle x(i%) + 6, y(i%) + 2, 5, , , CW, CW
Circle x(i%) - 6, y(i%) + 2, 5, , , CW, CW
Circle x(i%) + 6, y(i%) - 1, 5, , , c(i%), c(i%)
If (counter% + Choice(i% = 1, 0, 14)) And Choice(i% = 1, 28, 30) Then
Circle x(i%) - 6, y(i%) + 4, 2, , , 0, 0
Else
Circle x(i%) - 6, y(i%) - 1, 5, , , c(i%), c(i%)
EndIf
EndIf
Next
End Sub
' Draws circle whilst working around strange clipping behaviour when circle
' goes off screen.
Sub draw_circle(x%, y%, r%, col%)
Select Case x%
Case < 0 - r%, >= Mm.HRes + r%: Exit Sub
End Select
Select Case y%
Case < 0 - r%, >= Mm.VRes + r%: Exit Sub
End Select
Circle x%, y%, r%, , , col%, col%
End Sub
Sub handle_winning()
Local win%
If r(1) > Mm.VRes / 2 Then win% = 1
If (Not win%) And (r(2) > Mm.VRes / 2) Then win% = 2
If Not win% Then Exit Sub
Inc score(win%)
draw_score()
Const label$ = "win_" + Str$(win%) + "_data"
Const k% = display_text%(label$, Mm.VRes / 2 - 30)
start_round()
End Sub
win_1_data:
Data "Blue Wins", 2, CY, 17
Data "", 1, 0, 17
Data "Press START to continue", 1, CY, 17
Data "or SELECT to quit", 1, CY, 17
Data "", 0, 0, 0
win_2_data:
Data "Red Wins", 2, CY, 17
Data "", 1, 0, 17
Data "Press START to continue", 1, CY, 17
Data "or SELECT to quit", 1, CY, 17
Data "", 0, 0, 0
Sub draw_score()
Text 0, 0, Str$(score(1)), "LT", 8, 2, CB
Text Mm.HRes, 0, Str$(score(2)), "RT", 8, 2, CR
End Sub
Sub handle_pause()
pause_flag% = 0
Const key% = display_text%("pause_data", Mm.VRes / 2 - 30)
Cls
End Sub
pause_data:
Data "PAUSED", 2, CY, 17
Data "", 1, 0, 17
Data "Press START to continue", 1, CY, 17
Data "or SELECT to quit", 1, CY, 17
Data "", 0, 0, 0
' Konami Style Font (Martin H.)
' Font type : Full (95 ChArACtErs)
' Font size : 8x8 pixels
' Memory usage : 764 Bytes
DefineFont #8
5F200808
00000000 00000000 18181818 00180018 006C6C6C 00000000 367F3636 0036367F
3E683F0C 00187E0B 180C6660 00066630 386C6C38 003B666D 0030180C 00000000
3030180C 000C1830 0C0C1830 0030180C 3C7E1800 0000187E 7E181800 00001818
00000000 30181800 7E000000 00000000 00000000 00181800 180C0600 00006030
7E6E663C 003C6676 18183818 007E1818 0C06663C 007E3018 1C06663C 003C6606
6C3C1C0C 000C0C7E 067C607E 003C6606 7C60301C 003C6666 180C067E 00303030
3C66663C 003C6666 3E66663C 00380C06 18180000 00181800 18180000 30181800
6030180C 000C1830 007E0000 0000007E 060C1830 0030180C 180C663C 00180018
6A6E663C 003C606E 7E66663C 00666666 7C66667C 007C6666 6060663C 003C6660
66666C78 00786C66 7C60607E 007E6060 7C60607E 00606060 6E60663C 003C6666
7E666666 00666666 1818187E 007E1818 0C0C0C3E 00386C0C 70786C66 00666C78
60606060 007E6060 6B7F7763 0063636B 7E766666 0066666E 6666663C 003C6666
7C66667C 00606060 6666663C 00366C6A 7C66667C 0066666C 3C60663C 003C6606
1818187E 00181818 66666666 003C6666 66666666 00183C66 6B6B6363 0063777F
183C6666 0066663C 3C666666 00181818 180C067E 007E6030 6060607C 007C6060
18306000 0000060C 0606063E 003E0606 42663C18 00000000 00000000 FF000000
7C30361C 007E3030 063C0000 003E663E 667C6060 007C6666 663C0000 003C6660
663E0606 003E6666 663C0000 003C607E 7C30301C 00303030 663E0000 3C063E66
667C6060 00666666 18380018 003C1818 18380018 70181818 6C666060 00666C78
18181838 003C1818 7F360000 00636B6B 667C0000 00666666 663C0000 003C6666
667C0000 60607C66 663E0000 07063E66 766C0000 00606060 603E0000 007C063C
307C3030 001C3030 66660000 003E6666 66660000 00183C66 6B630000 00367F6B
3C660000 00663C18 66660000 3C063E66 0C7E0000 007E3018 7018180C 000C1818
00181818 00181818 0E181830 00301818 00466B31 00000000 FFFFFFFF FFFFFFFF
End DefineFont
No apologies necessary. Most (all ?) of the code I’ve worked on is written to run directly on MMB4L first and then be transpiled to work on other MMBasic platforms (mmbasic-sptools/src/sptrans/README.md at master · thwill1000/mmbasic-sptools · GitHub).
This will do more than cause a reboot it will erase the current contents of the A:/ flash drive so that MMBasic can reserve 128K for the MOD file buffer.
If you are going to be looking at porting more Game*Mite programs I recommend you make it:
OPTION MODBUFF ENABLE 192
As the 192K buffer is the Game*Mite default.
Best wishes,
Tom
2 Likes
That’s how I fixed it when I was testing it out.
I was wondering how the UI would hold up after being used to touch interfaces for Sudoku, but this works really nice.
1 Like
I was just working on a code for Sudoku. Glad that someone did it before me. My approach was a little bit different though: use solved puzzle, display all the numbers, but randomly hide a percentage from them.
1 Like