To run online, click here: RUN ONLINE
Code:
' PROGRAM STRON
' (c) 1983 by Roger Allen
' (c) 2023 by Zarsoft
' Written by Ze Oliveira
' Demo for the Pascalated language
' Pascalated Sinclair BASIC (c) 1987 by ZarSoft
' Pascalated BASIC Converter (c) 2021 by Zarsoft
' Pascalated Boriel (c) 2023 by ZarSoft
' ZX BASIC Compiler (c) 2008 by Boriel
#include <input.bas> ' number = VAL INPUT(12)
#include <screen.bas> ' SCREEN$ function
#include <attr.bas> ' ATTR function
'--- Pascalated Boriel ---
'#define CONST CONST
#define VAR DIM
#define INTEGER LONG
#define REAL FLOAT
#define CHAR STRING
'#define STRING STRING
#define BOOLEAN UBYTE
#define TYPE AS
'#define WHILE WHILE
#define REPEAT DO
#define UNTIL LOOP UNTIL
#define PROCEDURE SUB
#define PROGRAM REM
CONST TRUE TYPE BOOLEAN = 1
CONST FALSE TYPE BOOLEAN = 0
' CONSTant declarations
CONST Period TYPE INTEGER = 16
CONST Dlin TYPE INTEGER = 1
CONST Dcol TYPE INTEGER = 2
' VAR - Global variables
VAR GameOver TYPE BOOLEAN = FALSE
VAR BattleOver TYPE BOOLEAN = FALSE
VAR LIN, COL TYPE INTEGER ' coordinates of user
VAR Direction, DirectionOld TYPE INTEGER ' direction of user
VAR HighScore TYPE INTEGER
VAR Score TYPE INTEGER
VAR Zone TYPE INTEGER ' level number
VAR Tail$(8,8) TYPE STRING ' automaton for PrintTrail
VAR KeyMap$(128) TYPE STRING ' automaton to use several keys
VAR Dlc(8,2) TYPE INTEGER ' automaton for moveForward
VAR BikeSprite$(8) TYPE STRING ' automaton for bike
VAR EnemyLin$,EnemyCol$ TYPE STRING ' lin col of enemies
VAR Pointer TYPE INTEGER ' pointer to current enemy
VAR Clock,Clock0 TYPE INTEGER
VAR Lives TYPE INTEGER
'------------------------
FUNCTION UDG (c$ TYPE STRING) TYPE INTEGER
VAR result TYPE INTEGER
VAR svar TYPE INTEGER
VAR addr TYPE INTEGER
LET svar = 23675
LET addr = PEEK (svar) + 256*PEEK (svar+1)
IF c$ >= "\A" THEN LET c$ = CHR$(CODE(c$)+(CODE("A")-CODE("\A")))
IF c$ >= "a" THEN LET c$ = CHR$(CODE(c$)+(CODE("A")-CODE("a")))
LET result = addr+8*(CODE(c$)-CODE("A"))
RETURN result
END FUNCTION
'--- KEYBOARD BUFFER ---
VAR BUFFER$ TYPE STRING = ""
PROCEDURE ScanKey
VAR key$ TYPE STRING = INKEY$
VAR l TYPE INTEGER
IF key$ <> "" THEN
IF BUFFER$ = "" THEN
LET BUFFER$ = BUFFER$+INKEY$
ELSE
LET l = LEN BUFFER$
IF BUFFER$(l-1) <> key$ THEN LET BUFFER$ = BUFFER$+INKEY$
ENDIF
ENDIF
END PROCEDURE
FUNCTION GetKey$ TYPE STRING
VAR result$ TYPE STRING
VAR l TYPE INTEGER
LET l = LEN BUFFER$
IF l = 0
LET result$ = CHR 0
ELSEIF l = 1
LET result$ = BUFFER$
BUFFER$ = ""
ELSE
LET result$ = BUFFER$(0)
BUFFER$ = BUFFER$( 1 TO )
ENDIF
RETURN result$
END FUNCTION
'------------------------
CONST TRACE TYPE BOOLEAN = 1
PROCEDURE TRON (m$ TYPE STRING)
IF TRACE THEN
PRINT AT 1,10;INK 4;m$;TAB 31;
REPEAT
UNTIL INKEY$ = ""
REPEAT
UNTIL INKEY$ = "c"
ENDIF
END PROCEDURE
FUNCTION DeleteItem (ix TYPE INTEGER, s$ TYPE STRING) TYPE STRING
VAR result$ TYPE STRING
IF LEN s$ <= 1
result$ = ""
ELSEIF LEN s$ = 2
result$ = s$(1-ix)
ELSEIF ix = 0
LET result$ = s$(1 TO )
ELSEIF ix = LEN(s$) - 1
LET result$ = s$( TO ix-1)
ELSE
LET result$ = s$( TO ix-1) + s$(ix+1 TO )
ENDIF
RETURN result$
END FUNCTION
PROCEDURE MoveEnemies
VAR l,c TYPE INTEGER
VAR l0,c0 TYPE INTEGER
VAR elapsed TYPE INTEGER
VAR qt TYPE INTEGER = 4+Zone
REPEAT
ScanKey
LET l0 = CODE EnemyLin$(Pointer)
LET c0 = CODE EnemyCol$(Pointer)
LET l = l0+SGN(LIN-l0)
LET c = c0+SGN(COL-c0)
IF ATTR(l,c) = 0
PRINT AT l,c;INK 3;"\G";
PRINT AT l0,c0;" ";
LET EnemyLin$(Pointer) = CHR$ l
LET EnemyCol$(Pointer) = CHR$ c
ELSEIF ATTR(l,c) = 5
BORDER 2
PRINT AT l0,c0;" ";
PRINT AT l,c;" ";
EnemyLin$ = DeleteItem(Pointer,EnemyLin$)
EnemyCol$ = DeleteItem(Pointer,EnemyCol$)
LET Score = Score+10
PRINT AT 23,6;PAPER 0;INK 6;Score
ELSEIF ATTR(l,c) = 7
BORDER 2
PRINT AT l,c;INK 3;"\G";
PRINT AT l0,c0;" ";
PRINT AT LIN,COL;INK 6;"X"
LET Lives = Lives - 1
IF Lives = 0
LET GameOver = TRUE
ELSE
LET BattleOver = TRUE
ENDIF
ENDIF
LET qt = qt - 1
LET Pointer = Pointer-1
LET Clock = PEEK 23672
LET elapsed = Clock-Clock0: IF elapsed<0 THEN LET elapsed = elapsed+256
UNTIL qt = 0 OR elapsed >= Period OR Pointer < 0 OR GameOver
IF Pointer < 0 THEN LET Pointer = LEN EnemyLin$ - 1
IF LEN EnemyLin$ = 0 THEN LET Zone = Zone+1: LET BattleOver = TRUE
BORDER 0
END PROCEDURE
PROCEDURE PrintTrail
PRINT AT LIN,COL;INK 5; Tail$(DirectionOld,Direction);
END PROCEDURE
PROCEDURE MoveForward
VAR color TYPE INTEGER
PrintTrail
REM move bike
LET LIN = LIN + Dlc(Direction,Dlin)
LET COL = COL + Dlc(Direction,Dcol)
LET color = 1: IF LIN<22 THEN LET color = ATTR(LIN,COL)
IF color = 0
REM nothing ahead
PRINT AT LIN, COL;INK 7;BikeSprite$(Direction); : REM head of bike
ELSE
BORDER 2
IF LIN<22 THEN PRINT AT LIN,COL;INK 6;"X"
IF LIN=22 THEN PRINT AT 22,COL;PAPER 0;INK 6;"X"
LET Lives = Lives - 1
IF Lives = 0
LET GameOver = TRUE
ELSE
LET BattleOver = TRUE
ENDIF
ENDIF
LET DirectionOld = Direction
END PROCEDURE
PROCEDURE ShowEnemies
VAR N TYPE INTEGER
VAR l,c TYPE INTEGER
LET N=2^(Zone+0)
FOR i=1 TO N
LET l = 10-INT(10*RND*RND)
LET c = 30-INT(25*RND*RND)
IF ATTR(l,c) = 0 THEN PRINT AT l,c;INK 3;"\G";: LET EnemyLin$ = EnemyLin$ + CHR$(l): LET EnemyCol$ = EnemyCol$ + CHR$(c)
LET l = 11+INT(11*RND*RND)
LET c = 30-INT(25*RND*RND)
IF ATTR(l,c) = 0 THEN PRINT AT l,c;INK 3;"\G";: LET EnemyLin$ = EnemyLin$ + CHR$(l): LET EnemyCol$ = EnemyCol$ + CHR$(c)
NEXT i
LET Pointer = LEN EnemyLin$ - 1
END PROCEDURE
PROCEDURE InitBattle
BORDER 0: PAPER 0: INK 0: CLS
INK 1
REM top frame
PRINT AT 0,0;"\F\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\E";
REM vertical frame
FOR i=1 TO 21
REM left frame
PRINT AT i,0;"\B";
REM right frame
PRINT AT i,31;"\B";
NEXT i
REM bottom frame
PRINT AT 22,0;PAPER 0;INK 1;"\C\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\A\D";
REM Init Vars
REM Print titles
PRINT AT 0, 13; INK 4; "STRON";
PRINT AT 23,0;INK 6;"Score:";
PRINT AT 23,6;INK 6;Score;
PRINT AT 23,12;INK 6;"Max:";HighScore;
PRINT AT 23,24;INK 6;"Zone:";Zone;
PRINT AT 0,28;INK 2;"\J\J\J\J"(1 TO Lives);
LET LIN = 10 : LET COL = 2
PRINT AT LIN,COL;INK 7;"\H": REM head of bike
LET Direction = 0 : LET DirectionOld = 0 : REM must init with first move
LET EnemyLin$ = ""
LET EnemyCol$ = ""
LET BattleOver = FALSE
INK 0
ShowEnemies
LET Clock0 = PEEK 23672
LET Clock = PEEK 23672
END PROCEDURE
PROCEDURE InitGame
REM Init Vars
LET Zone = 1
LET Score = 0
LET Lives = 3
LET GameOver = FALSE
END PROCEDURE
PROCEDURE InitProg
LET HighScore = 0
REM automaton for PrintTrail
REM DIM Tail$(8,8)
LET Tail$(5,5) = "\A" : REM "-"
LET Tail$(5,6) = "\F" : REM "/"
LET Tail$(5,7) = "\C" : REM "\\"
LET Tail$(6,6) = "\B" : REM "|"
LET Tail$(6,5) = "\D" : REM "/"
LET Tail$(6,8) = "\C" : REM "\\"
LET Tail$(7,7) = "\B" : REM "|"
LET Tail$(7,5) = "\E" : REM "\\"
LET Tail$(7,8) = "\F" : REM "/"
LET Tail$(8,8) = "\A" : REM "-"
LET Tail$(8,6) = "\E" : REM "\\"
LET Tail$(8,7) = "\D" : REM "/"
REM automaton for moveForward
REM DIM Dlc(8,2)
LET Dlc(5,Dlin) = 0 : LET Dlc(5,Dcol) = -1
LET Dlc(6,Dlin) = 1 : LET Dlc(6,Dcol) = 0
LET Dlc(7,Dlin) = -1 : LET Dlc(7,Dcol) = 0
LET Dlc(8,Dlin) = 0 : LET Dlc(8,Dcol) = 1
REM Table for accept 5678 qaop and arrows
REM DIM KeyMap$(128)
REM left
LET KeyMap$(CODE "5") = "5"
LET KeyMap$(CODE "o") = "5"
LET KeyMap$(CODE "O") = "5"
LET KeyMap$(CODE "a") = "5"
LET KeyMap$(CODE "A") = "5"
LET KeyMap$(8) = "5" : REM left arrow
REM right
LET KeyMap$(CODE "8") = "8"
LET KeyMap$(CODE "p") = "8"
LET KeyMap$(CODE "P") = "8"
LET KeyMap$(CODE "d") = "8"
LET KeyMap$(CODE "D") = "8"
LET KeyMap$(9) = "8" : REM right arrow
REM up
LET KeyMap$(CODE "7") = "7"
LET KeyMap$(CODE "w") = "7"
LET KeyMap$(CODE "W") = "7"
LET KeyMap$(CODE "k") = "7"
LET KeyMap$(CODE "K") = "7"
LET KeyMap$(11) = "7" : REM up arrow
REM down
LET KeyMap$(CODE "6") = "6"
LET KeyMap$(CODE "s") = "6"
LET KeyMap$(CODE "S") = "6"
LET KeyMap$(CODE "m") = "6"
LET KeyMap$(CODE "M") = "6"
LET KeyMap$(10) = "6" : REM down arrow
REM automaton for bike
REM DIM BikeSprite$(8)
LET BikeSprite$(5) = "\H" : REM "-"
LET BikeSprite$(6) = "\I" : REM "|"
LET BikeSprite$(7) = "\I" : REM "|"
LET BikeSprite$(8) = "\H" : REM "-"
END PROCEDURE
PROCEDURE WaitClock
VAR elapsed TYPE INTEGER
REPEAT
ScanKey
LET Clock = PEEK 23672
LET elapsed = Clock-Clock0
IF elapsed<0 THEN LET elapsed = elapsed+256
UNTIL elapsed >= Period
LET Clock0 = Clock0 + Period: IF Clock0 > 255 THEN LET Clock0 = Clock0 - 256
REM PRINT AT 0,0;INK 2;elapsed;" ";
END PROCEDURE
PROCEDURE WaitForPlayer
VAR t$ TYPE STRING
VAR i TYPE INTEGER
FOR i = -10 TO 5: BEEP .005,i+10: BEEP .005,ABS i: NEXT i
REPEAT
PAUSE 0
LET t$ = KeyMap$(CODE (INKEY$+" ") )
UNTIL t$ >= "5" AND t$ <= "8"
REPEAT
UNTIL INKEY$ = ""
BEEP .1,20
LET Direction = VAL t$
LET DirectionOld = Direction
LET Clock0 = PEEK 23672
LET BUFFER$ = ""
END PROCEDURE
PROCEDURE DefineChars
VAR t$ TYPE STRING
VAR n TYPE INTEGER
VAR i TYPE INTEGER
VAR addr TYPE INTEGER
RESTORE
READ t$
REPEAT
REM LET addr = UDG(t$)
LET addr = USR(t$)
FOR i=0 TO 7
READ n
POKE addr+i,n
NEXT i
READ t$
UNTIL t$ = ""
END PROCEDURE
PROCEDURE DefineSprites
' UDG chars
DATA "A"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "B"
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA "C"
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011111
DATA BIN 00011111
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "D"
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 11111000
DATA BIN 11111000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "E"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 11111000
DATA BIN 11111000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA "F"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00011111
DATA BIN 00011111
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA "G"
DATA BIN 00000000
DATA BIN 11111110
DATA BIN 10010010
DATA BIN 11111110
DATA BIN 10000010
DATA BIN 10000010
DATA BIN 10000010
DATA BIN 11000110
DATA "H"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 01111110
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11100111
DATA BIN 00000000
DATA BIN 00000000
DATA "I"
DATA BIN 00111100
DATA BIN 00111100
DATA BIN 00111100
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00111100
DATA BIN 00111100
DATA BIN 00111100
DATA "J"
DATA BIN 01101100
DATA BIN 01111100
DATA BIN 11111110
DATA BIN 11111110
DATA BIN 01111100
DATA BIN 00111000
DATA BIN 00111000
DATA BIN 00010000
DATA ""
END PROCEDURE
PROCEDURE BattleEnd
VAR i TYPE INTEGER
IF NOT GameOver
PRINT AT 22,9;PAPER 7;INK 2; " BATTLE OVER "
FOR i = -15 TO 5 STEP 2: BEEP .05,i+10: BEEP .05,ABS i: NEXT i
REPEAT
UNTIL INKEY$ = ""
FOR i=1 TO 5
PAUSE 10
NEXT i
ENDIF
END PROCEDURE
PROCEDURE GameEnd
PRINT AT 22,10;PAPER 7;INK 2; " GAME OVER "
BEEP .5,15: BEEP .5,10: BEEP .5,5: BEEP .5,0
IF Score > HighScore
FOR i=1 TO 5
PAUSE 2
NEXT i
PRINT AT 0,8; INK 2;" NEW HIGH SCORE "
BEEP .5,10: BEEP .5,0: BEEP .5,20
LET HighScore = Score
ENDIF
REPEAT
UNTIL INKEY$ = ""
FOR i=1 TO 5
PAUSE 10
NEXT i
END PROCEDURE
PROCEDURE Introduction
VAR i TYPE INTEGER
BORDER 0: PAPER 0: INK 7: CLS
INK 3
PRINT " XXX XXXXX XXXX XXX X X"
PRINT "X X X X X X X XX X"
PRINT "X X X X X X X X X"
PRINT " XXX X XXXX X X X XX"
PRINT " X X X X X X X X"
PRINT "X X X X X X X X X"
PRINT " XXX X X X XXX X X"
PRINT INK 4;AT 10,4;"\*1983 by Roger Allen"
PRINT INK 4;AT 11,4;"\*2023 by ZarSoft"
PRINT INK 1;AT 19,0;" Pascalated BASIC "
PRINT INK 1;AT 20,0;" Compiled by ZX BASIC (Boriel) "
PRINT INK 5;AT 21,0;"Keys: 5678 WSOP WSAD ADKM arrows"
DefineChars
PRINT AT 0,0;
PRINT " \G\G\G \G\G\G\G\G \G\G\G\G \G\G\G \G \G"
PRINT "\G \G \G \G \G \G \G \G\G \G"
PRINT "\G \G \G \G \G \G \G \G \G"
PRINT " \G\G\G \G \G\G\G\G \G \G \G \G\G"
PRINT " \G \G \G \G \G \G \G \G"
PRINT "\G \G \G \G \G \G \G \G \G"
PRINT " \G\G\G \G \G \G \G\G\G \G \G"
FOR i = -20 TO 20: BEEP .005,i: BEEP .005,ABS i: NEXT i
PRINT AT 23,4;INK 2;"Press any key to start"
PAUSE 0
RANDOMIZE
END PROCEDURE
PROCEDURE Battle
VAR t$ TYPE STRING
InitBattle
WaitForPlayer
REPEAT
WaitClock
LET t$ = GetKey$
LET t$ = KeyMap$(CODE t$)
IF t$ >= "5" AND t$ <= "8" THEN IF Direction + VAL t$ <> 13 THEN LET Direction = VAL t$
MoveForward
MoveEnemies
REM WaitClock
BORDER 0
UNTIL BattleOver OR GameOver
BattleEnd
END PROCEDURE
PROCEDURE Game
InitGame
REPEAT
Battle
UNTIL GameOver
GameEnd
END PROCEDURE
PROCEDURE MainRoutine
Introduction
InitProg
REPEAT
Game
UNTIL FALSE
END PROCEDURE
PROGRAM STRON
MainRoutine
' last 2 lines are going to be deleted
PRINT AT 23,0;
END PROGRAM
