Forum
Pascalated ZX BASIC Demo #6 - STRON - Printable Version

+- Forum (https://www.boriel.com/forum)
+-- Forum: Compilers and Computer Languages (https://www.boriel.com/forum/forumdisplay.php?fid=12)
+--- Forum: ZX Basic Compiler (https://www.boriel.com/forum/forumdisplay.php?fid=11)
+---- Forum: Gallery (https://www.boriel.com/forum/forumdisplay.php?fid=18)
+---- Thread: Pascalated ZX BASIC Demo #6 - STRON (/showthread.php?tid=2337)



Pascalated ZX BASIC Demo #6 - STRON - zarsoft - 02-28-2023

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



RE: Pascalated ZX BASIC Demo #6 - STRON - boriel - 02-28-2023

Wow, this is reaching a new level!!
And playable online! Cool
I enjoyed it.