Pascalated ZX BASIC Demo #6 - STRON

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