| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 296
» Latest member: tubs74
» Forum threads: 1,034
» Forum posts: 6,240
Full Statistics
|
| Online Users |
There are currently 275 online users.
» 0 Member(s) | 272 Guest(s)
Applebot, Bing, Google
|
| Latest Threads |
Error on last version of ...
Forum: Bug Reports
Last Post: zarsoft
10-20-2024, 08:53 PM
» Replies: 4
» Views: 414
|
Error: Permission denied ...
Forum: Bug Reports
Last Post: zarsoft
10-16-2024, 01:48 PM
» Replies: 2
» Views: 322
|
LN(0.5) = positive!!!!! (...
Forum: Bug Reports
Last Post: boriel
10-09-2024, 09:36 PM
» Replies: 5
» Views: 495
|
Error: LET string1 = stri...
Forum: Bug Reports
Last Post: zarsoft
08-15-2024, 06:06 PM
» Replies: 3
» Views: 734
|
Error: loop ends every se...
Forum: Bug Reports
Last Post: zarsoft
08-11-2024, 05:41 PM
» Replies: 5
» Views: 999
|
Error: -1
Forum: Bug Reports
Last Post: boriel
08-10-2024, 08:17 AM
» Replies: 1
» Views: 443
|
attr.bas syntax error
Forum: Bug Reports
Last Post: csk
07-15-2024, 05:16 AM
» Replies: 2
» Views: 779
|
My computer is haunted!
Forum: Bug Reports
Last Post: zarsoft
05-22-2024, 10:30 AM
» Replies: 0
» Views: 625
|
Includes in ASM
Forum: How-To & Tutorials
Last Post: bracckets
04-04-2024, 12:17 AM
» Replies: 2
» Views: 2,239
|
Store array information i...
Forum: Help & Support
Last Post: rbiondi
03-10-2024, 09:42 PM
» Replies: 0
» Views: 1,275
|
|
|
| TAP be gone |
|
Posted by: zarsoft - 07-29-2023, 09:01 AM - Forum: Wishlist
- Replies (2)
|
 |
I wish ".tap" not to appear in the name of the recorded bytes.
"Game.tap" CODE 32768,12345
should be
"Game" CODE 32768,12345
".tap" already appears in the file name.
It does not need to appear again in the recorded block header.
|
|
|
| Pascalated ZX BASIC Demo #24 - Torpedo |
|
Posted by: zarsoft - 07-25-2023, 07:18 PM - Forum: Gallery
- No Replies
|
|
To run online, click here: RUN ONLINE
All Pascated BASIC demos are compiled with Boriel BASIC compiler just with BASIC without any assembly.
Code: ' PROGRAM Torpedo
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' 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 PROGRAM REM
#define BEGIN REM
'#define CONST CONST
#define VAR DIM
#define INTEGER LONG
#define REAL FLOAT
#define CHAR STRING ' UBYTE is type integer
'#define STRING STRING
#define BOOLEAN UBYTE
#define TYPE AS
'#define WHILE WHILE
#define REPEAT DO
#define UNTIL LOOP UNTIL
#define PROCEDURE SUB
'#define MOD MOD
CONST TRUE TYPE BOOLEAN = 1
CONST FALSE TYPE BOOLEAN = 0
PROGRAM Torpedo
' CONSTant declarations
REM CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST yellow = 6
CONST white = 7
CONST MaxTorpedos = 23 : REM min = 23 = 2+2+3+3+4+4+5
CONST FleetDelay = 20 : REM fleet speed
CONST TorpedoDelay = 5 : REM torpedo speed
CONST DepthChargeDelay = 15 : REM depth charge timeout
'CONST Blank$ TYPE STRING = " " ' 30 blank spaces *** compiler error
' VAR - Global variables
VAR Blank$ TYPE STRING = " " ' 30 blank spaces *** should be CONST
VAR Zeros$ TYPE STRING = "000000000000000000000000000000" ' 30 zeros
VAR Fleet1$,Fleet2$ TYPE STRING ' fleet silhouette
VAR Value$ TYPE STRING ' value of ship
VAR Part$ TYPE STRING ' part number of ship
VAR Life$ TYPE STRING ' life of ship
VAR Hit$ TYPE STRING ' hits
VAR Smoke2$ TYPE STRING ' smoke of hits
VAR Smoke1$ TYPE STRING ' smoke of hits
VAR MaxScore TYPE INTEGER
VAR Heading TYPE INTEGER ' center at 200
VAR Rotation TYPE INTEGER ' periscope rotation
VAR Shield TYPE INTEGER = 100
VAR Hits TYPE INTEGER ' hits on target
VAR Sink TYPE INTEGER ' ships destroyed
VAR Score TYPE INTEGER ' Current score
VAR RiposteDamage TYPE REAL ' Riposte damage (from depth charge)
VAR INDEX TYPE INTEGER
VAR DepthChargeTime TYPE INTEGER
VAR Torpedos TYPE INTEGER
VAR GameOver TYPE BOOLEAN
VAR Period TYPE INTEGER = 8
VAR CLICK TYPE INTEGER ' animation sprite bit selection 0 to 7
'---------------------------
PROCEDURE TRON (m$ TYPE STRING)
PRINT AT 0,17;TAB 31;
PRINT AT 0,17;INK 5;m$;
PAUSE 0
END PROCEDURE
'--- KEYBOARD BUFFER ---
VAR BUFFER$ TYPE STRING = ""
VAR LASTKEY$ TYPE STRING = ""
PROCEDURE ScanKey
VAR key$ TYPE STRING = INKEY$ + "#"
IF key$(0) <> LASTKEY$
LASTKEY$ = key(0)
LET BUFFER$ = BUFFER$+key$(0)
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$(0)
BUFFER$ = ""
ELSE
LET result$ = BUFFER$(0)
BUFFER$ = BUFFER$( 1 TO )
ENDIF
RETURN result$
END FUNCTION
FUNCTION LastKey$ TYPE STRING
RETURN LASTKEY$
END FUNCTION
'------------------------
VAR Clock,Clock0 TYPE INTEGER
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 SetSprites
POKE 23606,88 : POKE 23607,251-3*CLICK : REM Sprite
END PROCEDURE
PROCEDURE SetASCII
POKE 23606,0 : POKE 23607,60 : REM ZX Chars
END PROCEDURE
'------------------------
PROCEDURE TheEnd
BORDER 0
PRINT AT 3,14;PAPER 5;INK 2;"GAME";AT 4,14;"OVER"
IF Torpedos = 0 THEN PRINT AT 5,3;PAPER 0;INK 3;Torpedos;" ";
IF Shield = 0 THEN PRINT AT 8,1;PAPER 0;INK 3;INT(Shield+0.5);"% "
IF MaxScore < Score THEN LET MaxScore = Score
END PROCEDURE
PROCEDURE ShowFleet
SetSprites
PRINT AT 12,6;Fleet1$(INDEX+Rotation-10 TO INDEX+Rotation+10)
PRINT AT 11,6;Fleet2$(INDEX+Rotation-10 TO INDEX+Rotation+10)
PRINT AT 12,6;OVER 1;Smoke1$(INDEX+Rotation-10 TO INDEX+Rotation+10)
PRINT AT 11,6;OVER 1;Smoke2$(INDEX+Rotation-10 TO INDEX+Rotation+10)
SetASCII
END PROCEDURE
PROCEDURE ProcessDepthCharge
BORDER 2
LET Shield = Shield - RiposteDamage
IF Shield <= 0 THEN LET Shield = 0 : LET Score = Score - 500 : PRINT AT 21,26;PAPER 0;INK 7;" ";AT 21,26;Score : LET GameOver = TRUE
PRINT AT 8,1;PAPER 0;INK 7;INT(Shield+0.5);"% "
END PROCEDURE
PROCEDURE SetSmokeHit
LET Hit$(INDEX+Rotation) = "1"
IF Hit$(INDEX+Rotation-1) = "0" AND Hit$(INDEX+Rotation+1) = "0"
LET Smoke2$(INDEX+Rotation-1) = """"
LET Smoke1$(INDEX+Rotation-1) = "#"
LET Smoke2$(INDEX+Rotation) = "("
LET Smoke1$(INDEX+Rotation) = ")"
ELSEIF Hit$(INDEX+Rotation-1) = "0" AND Hit$(INDEX+Rotation+1) = "1"
LET Smoke2$(INDEX+Rotation-1) = """"
LET Smoke1$(INDEX+Rotation-1) = "#"
LET Smoke2$(INDEX+Rotation) = "$"
LET Smoke1$(INDEX+Rotation) = "%"
ELSEIF Hit$(INDEX+Rotation-1) = "1" AND Hit$(INDEX+Rotation+1) = "0"
LET Smoke2$(INDEX+Rotation-1) = "$"
LET Smoke1$(INDEX+Rotation-1) = "%"
LET Smoke2$(INDEX+Rotation) = "("
LET Smoke1$(INDEX+Rotation) = ")"
ELSEIF Hit$(INDEX+Rotation-1) = "1" AND Hit$(INDEX+Rotation+1) = "1"
LET Smoke2$(INDEX+Rotation-1) = "$"
LET Smoke1$(INDEX+Rotation-1) = "%"
LET Smoke2$(INDEX+Rotation) = "$"
LET Smoke1$(INDEX+Rotation) = "%"
ENDIF
END PROCEDURE
PROCEDURE SetSmokeSink (ShipStart TYPE INTEGER, ShipValue TYPE INTEGER)
VAR i TYPE INTEGER
LET i = 0
LET Smoke2$(ShipStart+i-1) = """"
LET Smoke1$(ShipStart+i-1) = "#"
FOR i = 1 TO ShipValue*2-1
' PRINT AT 12,16;PAPER 8;INK 2;OVER 1;" ";
LET Smoke2$(ShipStart+i-1) = "$"
LET Smoke1$(ShipStart+i-1) = "%"
NEXT i
LET i = ShipValue*2
LET Smoke2$(ShipStart+i-1) = "("
LET Smoke1$(ShipStart+i-1) = ")"
END PROCEDURE
' invoqued if Value$(INDEX+Rotation) > "0"
PROCEDURE ProcessHit
VAR ShipStart TYPE INTEGER
VAR ShipValue TYPE INTEGER
LET ShipValue = VAL Value$(INDEX+Rotation)
' hit
PRINT AT 12,16;PAPER 8;INK 2;OVER 1;" ";
IF Hit$(INDEX+Rotation) = "1" ' hit on old position
LET Score = Score + ShipValue
PRINT AT 21,26;PAPER 0;INK 7;" ";AT 21,26;Score
ELSE ' hit on new position
LET Score = Score + 10 * ShipValue
PRINT AT 21,26;PAPER 0;INK 7;" ";AT 21,26;Score
LET Hit$(INDEX+Rotation) = "1"
SetSmokeHit
LET Hits = Hits + 1
PRINT AT 5,28;PAPER 0;INK 7;Hits
'LET Value$(INDEX+Rotation) = "0"
LET ShipStart = (INDEX+Rotation) - VAL Part$(INDEX+Rotation)
LET Life$(ShipStart) = STR$ ( VAL Life$(ShipStart) - 1 )
IF Life$(ShipStart) = "0"
LET Sink = Sink + 1
PRINT AT 8,28;PAPER 0;INK 7;Sink;" ";
LET Score = Score + 10*ShipValue*ShipValue
PRINT AT 21,26;PAPER 0;INK 7;" ";AT 21,26;Score
SetSmokeSink (ShipStart,ShipValue)
ENDIF
BEEP .02,0 : BEEP .02,1 : BEEP .02,4 : BEEP .02,-1 :
ENDIF
END PROCEDURE
PROCEDURE FireTorpedo
VAR elapsed TYPE INTEGER
VAR ShipValue TYPE INTEGER
' update number of torpedos
LET Torpedos = Torpedos - 1
PRINT AT 5,3;PAPER 0;INK 7;Torpedos;" ";
' first half way
FOR CLICK = 0 TO 7
ShowFleet
PLOT PAPER 1;INK 7;131,35+3*CLICK : DRAW PAPER 1;INK 7;-2*(16-CLICK)*RND,0
PLOT PAPER 1;INK 7;131,35+3*CLICK : DRAW PAPER 1;INK 7;2*(16-CLICK)*RND,0
REPEAT
' time
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
' process deaph charge
BORDER 0
IF DepthChargeTime THEN LET DepthChargeTime = DepthChargeTime - 1 : IF DepthChargeTime = 0 THEN ProcessDepthCharge
NEXT CLICK
CLICK = 0
LET INDEX = INDEX + 1 : ShowFleet
' second half way
FOR CLICK = 0 TO 7
ShowFleet
PLOT PAPER 1;INK 7;131,35+3*(CLICK+8) : DRAW PAPER 1;INK 7;-(16-(CLICK+8))*RND,0
PLOT PAPER 1;INK 7;131,35+3*(CLICK+8) : DRAW PAPER 1;INK 7;(16-(CLICK+8))*RND,0
REPEAT
' time
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
' process deaph charge
BORDER 0
IF DepthChargeTime THEN LET DepthChargeTime = DepthChargeTime - 1 : IF DepthChargeTime = 0 THEN ProcessDepthCharge
NEXT CLICK
CLICK = 0
LET INDEX = INDEX + 1 : ShowFleet
' process hit
IF Value$(INDEX+Rotation) > "0"
ProcessHit
REM ship riposte
LET ShipValue = VAL Value$(INDEX+Rotation)
LET RiposteDamage = ShipValue*(1+1.0*RND)
LET DepthChargeTime = DepthChargeDelay-INT(RND*5)
ENDIF
' delete torpedo trail
PRINT AT 13,16;PAPER 1; " "
PRINT AT 14,16;PAPER 1; " "
PRINT AT 15,15;PAPER 1; " "
PRINT AT 16,14;PAPER 1; " "
PRINT AT 17,13;PAPER 1; " "
PRINT AT 18,12;PAPER 1;" "
PRINT AT 19,12;PAPER 1;" "
END PROCEDURE
PROCEDURE ShowKeys
PRINT AT 23,0;PAPER 0;INK 5;" Keys: 12 0 "
END PROCEDURE
PROCEDURE InitFleet
VAR r TYPE INTEGER
PRINT AT 3,14;PAPER 5;" ";AT 4,14;" " : REM delete GAME OVER
'DIM Blank$(30)
LET Fleet1$ = Blank$
LET Fleet2$ = Blank$
LET Value$ = Zeros$
LET Part$ = Blank$
LET Life$ = Blank$
LET Hit$ = ""
LET Smoke2$ = ""
LET Smoke1$ = ""
FOR i = 1 TO 7
PRINT AT 0,15;PAPER 0;INK 7;5*i;" ";
LET r = 1+INT (RND*5)
LET Fleet1$ = Fleet1$ + Blank$( TO r)
LET Fleet2$ = Fleet2$ + Blank$( TO r)
LET Value$ = Value$ + Value$( TO r)
LET Part$ = Part$ + Part$( TO r)
LET Life$ = Life$ + Life$( TO r)
IF i = 1 OR i = 7 THEN LET Value$ = Value$ + "02222" : LET Fleet2$ = Fleet2$ + " ": LET Fleet1$ = Fleet1$ + "+-/13" : LET Part$ = Part$ + " 0123" : LET Life$ = Life$ + " 2xxx"
IF i = 2 OR i = 6 THEN LET Value$ = Value$ + "0333333" : LET Fleet2$ = Fleet2$ + "468:<>@": LET Fleet1$ = Fleet1$ + "579;=?A" : LET Part$ = Part$ + " 012345" : LET Life$ = Life$ + " 3xxxxx"
IF i = 3 OR i = 5 THEN LET Value$ = Value$ + "044444444" : LET Fleet2$ = Fleet2$ + "BDFHJLNPR": LET Fleet1$ = Fleet1$ + "CEGIKMOQS" : LET Part$ = Part$ + " 01234567" : LET Life$ = Life$ + " 4xxxxxxx"
IF i = 4 THEN LET Value$ = Value$ + "05555555555" : LET Fleet2$ = Fleet2$ + "TVXZ\\^`bdfh": LET Fleet1$ = Fleet1$ + "UWY[]_acegi" : LET Part$ = Part$ + " 0123456789" : LET Life$ = Life$ + " 5xxxxxxxxx"
PAUSE 10
NEXT i
FOR i = 1 TO 3
PRINT AT 0,15;PAPER 0;INK 7;35+i*5;" ";
LET Fleet1$ = Fleet1$ + "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
LET Fleet2$ = Fleet2$ + Blank$
LET Value$ = Value$ + "000000000000000000000000000000"
LET Part$ = Part$ + Blank$
LET Life$ = Life$ + Blank$
PAUSE 10
NEXT i
FOR i = 1 TO LEN Fleet1$
Hit$ = Hit$ + "0"
Smoke2$ = Smoke2$ + " "
Smoke1$ = Smoke1$ + " "
NEXT i
' init clock
LET Clock = PEEK 23672
LET Clock0 = Clock0 + Period
' PRINT LEN Fleet1$, LEN Fleet2$, LEN Value$, LEN Part$, LEN Life$, LEN Hit$, LEN Smoke2$, LEN Smoke1$
' PAUSE 0
' PRINT Fleet1$( TO 90);TAB 0;Value$( TO 90);TAB 0; Part$( TO 90);TAB 0; Life$( TO 90)
' PAUSE 0
END PROCEDURE
PROCEDURE InitVariables
BORDER 0 : PAPER 5 : INK 0
LET GameOver = FALSE
InitFleet
LET INDEX = 30
LET Heading = 50+10*INT(10*RND)
LET Rotation = 0
PRINT AT 0,15;PAPER 0;INK 7;Heading+Rotation*5;" ";
LET Torpedos = MaxTorpedos
PRINT AT 5,3;PAPER 0;INK 7;Torpedos;" ";
LET Shield = 100
PRINT AT 8,1;PAPER 0;INK 7;Shield;"% "
LET Hits = 0
PRINT AT 5,28;PAPER 0;INK 7;Hits;" ";
LET Sink = 0
PRINT AT 8,28;PAPER 0;INK 7;Sink;" ";
LET Score = 0
PRINT AT 21,26;PAPER 0;INK 7;" ";AT 21,26;Score
PRINT AT 21,3;PAPER 0;INK 7;MaxScore
LET DepthChargeTime = 0
END PROCEDURE
PROCEDURE Game
VAR key$ TYPE STRING
VAR TorpedoLoaded TYPE BOOLEAN
VAR elapsed TYPE INTEGER
InitVariables
ShowKeys
ShowFleet
LET Clock0 = PEEK 23672 + Period
REPEAT ' game
'PRINT AT 0,20;PAPER 6;INK 0;Clock0;" ";
TorpedoLoaded = FALSE
FOR CLICK = 0 TO 7
ShowFleet
'PRINT AT 0,20;INDEX
' WaitClock
REPEAT
ScanKey
LET key$ = GetKey$
IF key$ = "1" AND NOT TorpedoLoaded THEN IF Heading+Rotation*5 > 0 THEN BEEP .02,10: LET Rotation = Rotation - 1 : PRINT AT 0,15;PAPER 0;INK 7;Heading+Rotation*5;" " : ShowFleet
IF key$ = "2" AND NOT TorpedoLoaded THEN IF Heading+Rotation*5 < 300 THEN BEEP .02,15: LET Rotation = Rotation + 1 : PRINT AT 0,15;PAPER 0;INK 7;Heading+Rotation*5;" " : ShowFleet
IF key$ = "0" AND NOT TorpedoLoaded AND Torpedos > 0 THEN PRINT AT 23,8;PAPER 0;INK 6;"Loading torpedo";: TorpedoLoaded = TRUE
' time
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
BORDER 0
IF TorpedoLoaded THEN BEEP .01,5*(CLICK+RND)
' process deaph charge
IF DepthChargeTime THEN LET DepthChargeTime = DepthChargeTime - 1 : IF DepthChargeTime = 0 THEN ProcessDepthCharge
NEXT CLICK
CLICK = 0
LET INDEX = INDEX + 1 : ShowFleet : IF Fleet1$(INDEX-10) = "!" THEN LET GameOver = TRUE
IF TorpedoLoaded THEN PRINT AT 23,8;PAPER 0;INK 7;" ";: FireTorpedo
UNTIL GameOver
TheEnd
END PROCEDURE
PROCEDURE PressStart
VAR key$ TYPE STRING
PRINT AT 23,0;PAPER 0;INK 7;" Press ";INK 2;"S";INK 7;"tart ";
REPEAT
PAUSE(50)
LET key$ = INKEY$
UNTIL key$ = "s" OR key$ = "S"
PRINT AT 3,14;PAPER 5;INK 2;" ";AT 4,14;" ": REM delete Game Over
PRINT AT 23,0;PAPER 0;INK 6;" Scanning fleet... "
RANDOMIZE
END PROCEDURE
PROCEDURE ShowScreen
BORDER 0: PAPER 0: INK 0
REM sky
PAPER 5: OVER 1
PRINT AT 1,15;" "
PRINT AT 2,12;" "
PRINT AT 3,10;" "
PRINT AT 4,9;" "
PRINT AT 5,8;" "
PRINT AT 6,8;" "
PRINT AT 7,8;" "
PRINT AT 8,7;" "
PRINT AT 9,7;" "
PRINT AT 10,7;" "
PRINT AT 11,7;" "
PRINT AT 12,7;" "
PAPER 1: OVER 1
PRINT AT 13,7;" "
PRINT AT 14,7;" "
PRINT AT 15,7;" "
PRINT AT 16,8;" "
PRINT AT 17,8;" "
PRINT AT 18,9;" "
PRINT AT 19,10;" "
PRINT AT 20,12;" "
PRINT AT 21,15;" "
OVER 0
REM Instruments
PAPER 0 : INK 7
PRINT AT 0,7;"HEADING"
PRINT AT 4,0;"TORPEDOS"
PRINT AT 7,0;"SHIELD"
PRINT AT 4,27;"HITS"
PRINT AT 7,27;"SHIPS"
PRINT AT 20,25;"SCORE"
PRINT AT 20,0;"MAX SCORE"
PAPER 5 : INK 0
END PROCEDURE
PROCEDURE TestSprites
SetSprites
PRINT
PRINT " "
PRINT "+-/13"
PRINT
PRINT "468:<>@"
PRINT "579;=?A"
PRINT
PRINT "BDFHJLNPR"
PRINT "CEGIKMOQS"
PRINT
PRINT "TVXZ\\^`bdfh"
PRINT "UWY[]_acegi"
PRINT
PRINT """$&("
PRINT "#%')"
PRINT
SetASCII
END PROCEDURE
PROCEDURE SaveShips
SAVE "ships" CODE 64600,96*8
END PROCEDURE
PROCEDURE LoadShips
LOAD "ships" CODE 64600
END PROCEDURE
PROCEDURE MainRoutine
ShowScreen
PressStart
REPEAT
Game
PressStart
UNTIL FALSE
END PROCEDURE
PROGRAM Torpedo
' TestSprites: PAUSE 0
PRINT AT 23,7;PAPER 0;INK 4;"(c) 2023 by Zarsoft";
FOR n=0 TO 30: BEEP .01,n: NEXT n
PRINT AT 23,0;PAPER 0;INK 7;"Pascalated Boriel ZX BASIC demo";
PAUSE 3*50
MainRoutine
PRINT AT 23,10;INK 2;"The End"
END PROGRAM
|
|
|
|
| Pascalated ZX BASIC Demo #23 - Space Invader |
|
Posted by: zarsoft - 07-16-2023, 06:12 PM - Forum: Gallery
- No Replies
|
|
To run online, click here: RUN ONLINE
Code: ' PROGRAM Space Invader
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' 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 PROGRAM REM
#define BEGIN REM
'#define CONST CONST
#define VAR DIM
#define INTEGER LONG
#define REAL FLOAT
#define CHAR STRING ' UBYTE is type integer
'#define STRING STRING
#define BOOLEAN UBYTE
#define TYPE AS
'#define WHILE WHILE
#define REPEAT DO
#define UNTIL LOOP UNTIL
#define PROCEDURE SUB
CONST TRUE TYPE BOOLEAN = 1
CONST FALSE TYPE BOOLEAN = 0
PROGRAM SpaceInvader
' CONSTant declarations
REM CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST yellow = 6
CONST white = 7
CONST ZXscreen = 22528
CONST GameScreen = ZXscreen+4+4*32
' VAR - Global variables
VAR INKoff TYPE INTEGER = blue
VAR INKon TYPE INTEGER= cyan
VAR LEDoff TYPE INTEGER = INKoff+64
VAR LEDon TYPE INTEGER = INKon+64
VAR VIDEO(8,6) TYPE INTEGER ' video memory
VAR ADDR(8,6) TYPE INTEGER ' video address
VAR score1 TYPE INTEGER
VAR score2 TYPE INTEGER
VAR score3 TYPE INTEGER
VAR PlayerLin TYPE INTEGER
VAR PlayerCol TYPE INTEGER
VAR MissileLin TYPE INTEGER
VAR MissileCol TYPE INTEGER
VAR BombLin TYPE INTEGER
VAR BombCol TYPE INTEGER
VAR MothershipLin TYPE INTEGER
VAR MothershipCol TYPE INTEGER
VAR MothershipInc TYPE INTEGER
VAR Enemies TYPE INTEGER
VAR ScrollState TYPE INTEGER
VAR ScrollLin TYPE INTEGER
VAR ScrollCol TYPE INTEGER
VAR GameOver TYPE BOOLEAN
' VAR Scroll TYPE INTEGER = VAL ("Scroll"+STR$ ScrollState)
VAR k$ TYPE CHAR
VAR Period TYPE INTEGER = 16
'--- KEYBOARD BUFFER ---
VAR BUFFER$ TYPE STRING = ""
VAR LASTKEY$ TYPE STRING = ""
PROCEDURE ScanKey
VAR key$ TYPE STRING = INKEY$ + "#"
IF key$(0) <> LASTKEY$
LASTKEY$ = key(0)
LET BUFFER$ = BUFFER$+key$(0)
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$(0)
BUFFER$ = ""
ELSE
LET result$ = BUFFER$(0)
BUFFER$ = BUFFER$( 1 TO )
ENDIF
RETURN result$
END FUNCTION
FUNCTION LastKey$ TYPE STRING
RETURN LASTKEY$
END FUNCTION
'------------------------
VAR Clock,Clock0 TYPE INTEGER
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 InitADDR
VAR l,c TYPE INTEGER
FOR l=1 TO 8
FOR c=1 TO 6
ADDR(l,c) = GameScreen+l*64+c*3
' POKE ADDR(l,c),18
NEXT c
NEXT l
END PROCEDURE
PROCEDURE ShipOFF (l TYPE INTEGER,c TYPE INTEGER)
VAR addr TYPE INTEGER
VIDEO(l,c) = 0
addr = ADDR(l,c)
POKE addr,LEDoff: POKE addr+1,LEDoff: POKE addr+2,LEDoff
END PROCEDURE
PROCEDURE ShipON (l TYPE INTEGER,c TYPE INTEGER)
VAR addr TYPE INTEGER
IF VIDEO(l,c) = 0 THEN VIDEO(l,c) = 1 ' do not change shield value
addr = ADDR(l,c)
POKE addr,LEDon: POKE addr+1,LEDon: POKE addr+2,LEDon
END PROCEDURE
PROCEDURE FireOFF (l TYPE INTEGER,c TYPE INTEGER)
VAR addr TYPE INTEGER
addr = ADDR(l,c)
IF VIDEO(l,c) = 0 THEN POKE addr+1,LEDoff
END PROCEDURE
PROCEDURE FireON (l TYPE INTEGER,c TYPE INTEGER)
VAR addr TYPE INTEGER
addr = ADDR(l,c)
IF VIDEO(l,c) = 0 THEN POKE addr+1,LEDon
END PROCEDURE
'------------------------
'------------------------
PROCEDURE ChangeColors
VAR l,c TYPE INTEGER
VAR oldOFF,oldON TYPE INTEGER
oldOFF = LEDoff
oldON = LEDon
INKoff = (black+blue)-INKoff
INKon = (red+cyan)-INKon
LEDoff = INKoff+64
LEDon = INKon+64
' update colors on screen
FOR l=2 TO 4
FOR c=7 TO 24
IF ATTR(l,c) = oldOFF THEN PRINT AT l,c;OVER 1;BRIGHT 1;PAPER 8;INK LEDoff;" ";
IF ATTR(l,c) = oldON THEN PRINT AT l,c;OVER 1;BRIGHT 1;PAPER 8;INK LEDon;" ";
NEXT c
NEXT l
FOR l=6 TO 20 STEP 2
FOR c=7 TO 24
IF ATTR(l,c) = oldOFF THEN PRINT AT l,c;OVER 1;BRIGHT 1;PAPER 8;INK LEDoff;" ";
IF ATTR(l,c) = oldON THEN PRINT AT l,c;OVER 1;BRIGHT 1;PAPER 8;INK LEDon;" ";
NEXT c
NEXT l
END PROCEDURE
'------------------------
PROCEDURE ShowScore
IF score1 > 9 THEN LET score1 = score1-10: LET score2 = score2 + 1: IF score2 > 9 THEN LET score2 = score2-10: LET score3 = score3 + 1: IF score3 > 9 THEN LET score3 = score3-10
ShowDigit(1,score1)
ShowDigit(2,score2)
ShowDigit(3,score3)
END PROCEDURE
'------------------------
PROCEDURE NewWave
' Period for game speed
LET Period = Period-1: IF Period < 8 THEN LET Period = 8
' Enemies
LET VIDEO(2,1) = 1: LET VIDEO(2,2) = 1: LET VIDEO(2,3) = 1: LET VIDEO(2,4) = 1
LET VIDEO(3,1) = 1: LET VIDEO(3,2) = 1: LET VIDEO(3,3) = 1: LET VIDEO(3,4) = 1
LET Enemies = 8
' bombs and missiles
LET BombLin = 0
LET BombCol = 0
LET MissileLin = 0
LET MissileCol = 0
' Scroll
LET ScrollState = 1
LET ScrollLin = 6
LET ScrollCol = 6
' refresh screen
FOR l=1 TO 8
FOR c=1 TO 6
IF VIDEO(l,c) = 0
ShipOFF(l,c)
ELSE
ShipON(l,c)
ENDIF
NEXT c
NEXT l
END PROCEDURE
'------------------------
PROCEDURE MoveLeft
VAR i TYPE INTEGER
IF PlayerCol > 1
ShipOFF(PlayerLin,PlayerCol)
LET PlayerCol = PlayerCol - 1
ShipON(PlayerLin,PlayerCol)
BEEP .01,5
ENDIF
END PROCEDURE
PROCEDURE MoveRight
VAR i TYPE INTEGER
IF PlayerCol < 6
ShipOFF(PlayerLin,PlayerCol)
LET PlayerCol = PlayerCol + 1
ShipON(PlayerLin,PlayerCol)
BEEP .01,5
ENDIF
END PROCEDURE
PROCEDURE MissileFire
IF MissileLin = 0
IF VIDEO(7,PlayerCol) = 0 ' freeway
LET MissileLin = 7
LET MissileCol = PlayerCol
FireON(MissileLin,MissileCol)
BEEP .1,5
ENDIF
ENDIF
END PROCEDURE
PROCEDURE MissileGo
FireOFF(MissileLin,MissileCol)
LET MissileLin = MissileLin-1
IF MissileLin >= 1 ' free way
IF VIDEO(MissileLin,MissileCol) = 0
FireON(MissileLin,MissileCol)
ELSE
IF MissileLin = 1 ' hit on mothership
ShipOFF(MissileLin,MissileCol): LET MothershipCol = 0
LET score1 = score1 + 5: ShowScore
LET MissileLin = 0
BEEP .01,0: BEEP .01,10: BEEP .01,20: BEEP .01,30
ELSE ' hit on ship
ShipOFF(MissileLin,MissileCol)
LET Enemies = Enemies - 1: LET score1 = score1 + 2: ShowScore
LET MissileLin = 0
BEEP .01,0: BEEP .01,10: BEEP .01,20: BEEP .01,30
IF Enemies = 0 THEN NewWave: FOR n=0 TO 30: BEEP .01,n: NEXT n
ENDIF
ENDIF
ENDIF
END PROCEDURE
PROCEDURE BombDrop
LET BombLin = 6
LET BombCol = 1+INT(RND*6)
WHILE VIDEO(BombLin,BombCol) = 0 AND BombLin >= 1
LET BombLin = BombLin-1
END WHILE
IF BombLin = 1
LET BombLin = BombLin+1
FireON(BombLin,BombCol)
ENDIF
END PROCEDURE
PROCEDURE BombGo
FireOFF(BombLin,BombCol)
LET BombLin = BombLin+1
IF BombLin = 9
REM ground zero
LET BombLin = 0
ELSEIF VIDEO(BombLin,BombCol) = 0 ' free way
FireON(BombLin,BombCol)
ELSEIF BombLin = 7 ' hit shield
LET VIDEO(7,BombCol) = VIDEO(7,BombCol)-1: IF VIDEO(7,BombCol) = 0 THEN ShipOFF(7,BombCol): BEEP .2,30
LET BombLin = 0
ELSEIF BombLin = 8 ' hit defender
ShipOFF(PlayerLin,PlayerCol)
LET BombLin = 0
BEEP .2,5: BEEP .2,7: BEEP .2,0: BEEP .4,0
LET GameOver = TRUE
ENDIF
END PROCEDURE
PROCEDURE MothershipStart
VAR i TYPE INTEGER
LET MothershipInc = -MothershipInc
LET MothershipCol = 1+5*(MothershipInc = -1)
ShipON(MothershipLin,MothershipCol)
END PROCEDURE
PROCEDURE MothershipGo
ShipOFF(MothershipLin,MothershipCol)
LET MothershipCol = MothershipCol + MothershipInc
IF MothershipCol < 1 OR MothershipCol > 6
LET MothershipCol = 0
ELSE
ShipON(MothershipLin,MothershipCol)
ENDIF
END PROCEDURE
' scroll right
PROCEDURE Scroll1
VAR l TYPE INTEGER
REM shift ship
FOR l = 6 TO 2 STEP -1
IF VIDEO(l,ScrollCol-1) > 0 THEN ShipON(l,ScrollCol): ShipOFF(l,ScrollCol-1)
NEXT l
LET ScrollCol = ScrollCol-1
IF ScrollCol = 1
IF VIDEO(2,6) + VIDEO(3,6) + VIDEO(4,6) + VIDEO(5,6) + VIDEO(6,6) = 0
REM continue scroll right
LET ScrollState = 1
LET ScrollCol = 6
ELSE
REM goto scroll down (at right corner)
LET ScrollState = 2
LET ScrollCol = 6
IF VIDEO(6,1) + VIDEO(6,2) + VIDEO(6,3) + VIDEO(6,4) + VIDEO(6,5) + VIDEO(6,6) > 0 THEN BEEP .1,5: BEEP .1,7: BEEP .1,0: BEEP .1,0: LET GameOver = TRUE
ENDIF
ENDIF
END PROCEDURE
' scroll down (at right corner)
PROCEDURE Scroll2
VAR l TYPE INTEGER
REM shift ship
FOR l = 6 TO 3 STEP -1
IF VIDEO(l-1,ScrollCol) > 0 THEN ShipON(l,ScrollCol): ShipOFF(l-1,ScrollCol)
NEXT l
LET ScrollCol = ScrollCol-1
IF ScrollCol = 1 ' goto scroll left
LET ScrollState = 3
LET ScrollCol = 1
ENDIF
END PROCEDURE
' scroll left
PROCEDURE Scroll3
VAR i TYPE INTEGER
REM shift ship
FOR i = 6 TO 2 STEP -1
IF VIDEO(i,ScrollCol+1) > 0 THEN ShipON(i,ScrollCol): ShipOFF(i,ScrollCol+1)
NEXT i
LET ScrollCol = ScrollCol+1
IF ScrollCol = 6
IF VIDEO(2,1) + VIDEO(3,1) + VIDEO(4,1) + VIDEO(5,1) + VIDEO(6,1) = 0
REM continue scroll left
LET ScrollState = 3
LET ScrollCol = 1
ELSE
REM goto scroll down (at right corner)
LET ScrollState = 4
LET ScrollCol = 1
IF VIDEO(6,1) + VIDEO(6,2) + VIDEO(6,3) + VIDEO(6,4) + VIDEO(6,5) + VIDEO(6,6) > 0 THEN BEEP .1,5: BEEP .1,7: BEEP .1,0: BEEP .1,0: LET GameOver = TRUE
ENDIF
ENDIF
END PROCEDURE
' scroll down (at left corner)
PROCEDURE Scroll4
VAR l TYPE INTEGER
REM shift ship
FOR l = 6 TO 3 STEP -1
IF VIDEO(l-1,ScrollCol) > 0 THEN ShipON(l,ScrollCol): ShipOFF(l-1,ScrollCol)
NEXT l
LET ScrollCol = ScrollCol+1
IF ScrollCol = 6 ' goto scroll right
LET ScrollState = 1
LET ScrollCol = 5
ENDIF
END PROCEDURE
PROCEDURE Scroll
IF ScrollState = 1
Scroll1
ELSEIF ScrollState = 2
Scroll2
ELSEIF ScrollState = 3
Scroll3
ELSEIF ScrollState = 4
Scroll4
ENDIF
END PROCEDURE
PROCEDURE ShowDigit0 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\: \ :";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\:.\.:";
END PROCEDURE
PROCEDURE ShowDigit1 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\ \ .";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\ \ :";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\ \ :";
END PROCEDURE
PROCEDURE ShowDigit2 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\..\.:";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\:.\..";
END PROCEDURE
PROCEDURE ShowDigit3 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\..\.:";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\..\.:";
END PROCEDURE
PROCEDURE ShowDigit4 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\. \ .";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\:.\.:";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\ \ :";
END PROCEDURE
PROCEDURE ShowDigit5 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\:.\..";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\..\.:";
END PROCEDURE
PROCEDURE ShowDigit6 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\:.\..";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\:.\.:";
END PROCEDURE
PROCEDURE ShowDigit7 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\ \ :";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\ \ :";
END PROCEDURE
PROCEDURE ShowDigit8 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\:.\.:";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\:.\.:";
END PROCEDURE
PROCEDURE ShowDigit9 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\:.\.:";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\ \ :";
END PROCEDURE
PROCEDURE ShowDigit (ndigit TYPE INTEGER, value TYPE INTEGER)
VAR col TYPE INTEGER
LET col = 12+3*(3-ndigit)
IF value = 0
ShowDigit0 (col)
ELSEIF value = 1
ShowDigit1 (col)
ELSEIF value = 2
ShowDigit2 (col)
ELSEIF value = 3
ShowDigit3 (col)
ELSEIF value = 4
ShowDigit4 (col)
ELSEIF value = 5
ShowDigit5 (col)
ELSEIF value = 6
ShowDigit6 (col)
ELSEIF value = 7
ShowDigit7 (col)
ELSEIF value = 8
ShowDigit8 (col)
ELSEIF value = 9
ShowDigit9 (col)
ENDIF
END PROCEDURE
PROCEDURE ClearScreen
FOR i=2 TO 20
PRINT AT i,7;OVER 1;BRIGHT 1;INK LEDoff;" ";
NEXT i
END PROCEDURE
PROCEDURE Game
VAR active TYPE INTEGER
VAR k$ TYPE STRING
VAR elapsed TYPE INTEGER
REPEAT
REM process1
'WaitClock
REPEAT
ScanKey
LET k$ = GetKey$
IF k$ = "1" THEN MoveLeft
IF k$ = "2" THEN MoveRight
IF k$ = "0" THEN MissileFire
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
LET active = MothershipCol
IF NOT active THEN MothershipStart
IF active THEN MothershipGo
LET active = BombLin
'IF Enemies > 3 THEN IF active+RND < ((score3+1.5)*10+score2)/50 THEN BombDrop
IF NOT active THEN BombDrop
IF active THEN BombGo
IF MissileLin THEN MissileGo
REM process2
'WaitClock
REPEAT
ScanKey
LET k$ = GetKey$
IF k$ = "1" THEN MoveLeft
IF k$ = "2" THEN MoveRight
IF k$ = "0" THEN MissileFire
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
LET active = MothershipCol
IF NOT active THEN MothershipStart
IF active THEN MothershipGo
LET active = BombLin
'IF Enemies > 3 THEN IF active+RND < ((score3+1.5)*10+score2)/50 THEN BombDrop
IF NOT active THEN BombDrop
IF active THEN BombGo
IF MissileLin THEN MissileGo
REM process3
Scroll
UNTIL GameOver
END PROCEDURE
PROCEDURE WaitForPlayer
PRINT AT 23,6;PAPER blue;INK white;" [s] [c]";
REPEAT
PAUSE 0
LET k$ = INKEY$
IF k$ = "c" THEN ChangeColors
UNTIL k$ = "s"
BEEP .4,5
RANDOMIZE
LET Clock0 = PEEK 23672
PRINT AT 23,6;PAPER blue;INK white;" [1][2] [0]";
END PROCEDURE
PROCEDURE InitGame
VAR l,c TYPE INTEGER
LET Period = 16+1
' score
LET score1 = 0
LET score2 = 0
LET score3 = 0
ShowScore
' clear screen
FOR l=1 TO 8
FOR c=1 TO 6
VIDEO(l,c) = 0
NEXT c
NEXT l
' Mothership
LET MothershipLin = 1
LET MothershipCol = 0
LET MothershipInc = -1
' defense shield
LET VIDEO(7,2) = 10: LET VIDEO(7,5) = 10
' Player
LET PlayerLin = 8
LET PlayerCol = 1
LET VIDEO(PlayerLin,PlayerCol) = 1
' new wave
NewWave
' extra
LET GameOver = FALSE
END PROCEDURE
PROCEDURE InitScreen
BORDER 1: PAPER 1: INK 7: CLS
PRINT AT 0,8;INK 7;"* SPACE INVADER *";
PAPER 0
FOR i=1 TO 21
PRINT AT i,6;INK 1;" ";
NEXT i
PRINT AT 1,6;INK 7;"\:'\''\''\''\''\''\''\''\''\''\''\''\''\''\''\''\''\''\''\':";
FOR i=2 TO 20
PRINT AT i,6;INK 7;"\: ";
PRINT AT i,25;INK 7;"\ :";
NEXT i
PRINT AT 21,6;INK 7;"\:.\..\..\..\..\..\..\..\..\..\..\..\..\..\..\..\..\..\..\.:";
REM PLOT 11*8,176-2*8: DRAW 10*8,0: DRAW 0,-4*8+4: DRAW -10*8,0: DRAW 0,4*8-4
PRINT AT 2,12;INK INKoff;"\..\.. \..\.. \..\..";
PRINT AT 3,12;INK INKoff;"\:.\.: \:.\.: \:.\.:";
PRINT AT 4,12;INK INKoff;"\:.\.: \:.\.: \:.\.:";
PRINT AT 6,7;BRIGHT 1;INK INKoff;"\A\B\C\A\B\C\A\B\C\A\B\C\A\B\C\A\B\C";
FOR i=1 TO 5
PRINT AT 6+i*2,7;BRIGHT 1;INK INKoff;"\D\E\F\D\E\F\D\E\F\D\E\F\D\E\F\D\E\F";
NEXT i
REM PRINT AT 18,7;INK INKoff;" \G\H\I \G\H\I";
REM PRINT AT 19,7;INK INKoff;" \E \E \E \E \E \E ";
PRINT AT 18,7;BRIGHT 1;INK INKoff;"\M\E\N\M\E\N\M\E\N\M\E\N\M\E\N\M\E\N";
PRINT AT 20,7;BRIGHT 1;INK INKoff;"\J\K\L\J\K\L\J\K\L\J\K\L\J\K\L\J\K\L";
REM PRINT AT 23,7;INK 7;"12 keys 90";
PRINT AT 23,6;PAPER blue;INK white;" [1][2] [0]";
END PROCEDURE
PROCEDURE DefineChars
VAR i,n TYPE INTEGER
VAR b$ TYPE STRING
RESTORE ' DataChars
READ b$
REPEAT
FOR i=0 TO 7
READ n
POKE USR b$+i,n
NEXT i
READ b$
UNTIL b$ = ""
END PROCEDURE
PROCEDURE DataChars
DATA "A"
DATA BIN 00000000
DATA BIN 00000011
DATA BIN 00000001
DATA BIN 00011111
DATA BIN 00111111
DATA BIN 01111111
DATA BIN 00111111
DATA BIN 00000111
DATA "B"
DATA BIN 00111100
DATA BIN 11111111
DATA BIN 01011010
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 00111100
DATA "C"
DATA BIN 00000000
DATA BIN 11000000
DATA BIN 10000000
DATA BIN 11111000
DATA BIN 11111100
DATA BIN 11111110
DATA BIN 11111100
DATA BIN 11100000
DATA "D"
DATA BIN 00000010
DATA BIN 00000010
DATA BIN 00000110
DATA BIN 00001111
DATA BIN 00001111
DATA BIN 00011100
DATA BIN 00010000
DATA BIN 00010000
DATA "E"
DATA BIN 00011000
DATA BIN 00111100
DATA BIN 01111110
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 01111110
DATA BIN 00111100
DATA BIN 00011000
DATA "F"
DATA BIN 01000000
DATA BIN 01000000
DATA BIN 01100000
DATA BIN 11110000
DATA BIN 11110000
DATA BIN 00110000
DATA BIN 00010000
DATA BIN 00001000
END PROCEDURE
PROCEDURE DataChars2
DATA "G"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000001
DATA BIN 00000111
DATA BIN 00011111
DATA BIN 01111111
DATA BIN 00000000
DATA BIN 00000000
DATA "H"
DATA BIN 00011000
DATA BIN 01111110
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 00000000
DATA BIN 00000000
DATA "I"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 10000000
DATA BIN 11100000
DATA BIN 11111000
DATA BIN 11111110
DATA BIN 00000000
DATA BIN 00000000
DATA "J"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00011111
DATA BIN 00111111
DATA BIN 01111111
DATA BIN 00111111
DATA BIN 00011110
DATA "K"
DATA BIN 00011000
DATA BIN 01111110
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 00000000
DATA "L"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 11110000
DATA BIN 11111100
DATA BIN 11111110
DATA BIN 11111100
DATA BIN 01111000
DATA "M"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00001111
DATA BIN 00011111
DATA BIN 00111100
DATA BIN 01111000
DATA BIN 11110000
DATA "N"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 11110000
DATA BIN 11111000
DATA BIN 00111100
DATA BIN 00011110
DATA BIN 00001111
DATA ""
END PROCEDURE
PROCEDURE TellStory
BORDER 1: PAPER 1: INK 7: CLS
PRINT AT 5,0;"In 1980 was launched"
PRINT TAB 0;"the first handheld videogame:"
PRINT TAB 5;""
PRINT TAB 5;INK 6;"SPACE INVADER"
PRINT TAB 5;" by Entex"
PRINT TAB 5;""
PRINT TAB 5;"Red leds screen"
PRINT TAB 5;"6 x 8 resolution"
PRINT TAB 5;"6 AA batteries"
PRINT TAB 5;""
PRINT TAB 0;"On youtube search:"
PRINT TAB 0;" Entex Space Invader"
PAUSE 15*50
END PROCEDURE
PROCEDURE MainRoutine
TellStory
DefineChars
InitADDR
InitScreen
WaitForPlayer
InitGame
REPEAT
Game
WaitForPlayer
ClearScreen
InitGame
UNTIL FALSE
END PROCEDURE
PROGRAM SpaceInvader
FOR n=0 TO 30: BEEP .01,n: NEXT n
PRINT AT 23,0;"Pascalated Boriel ZX BASIC demo";
PAUSE 3*50
MainRoutine
PRINT AT 21,10;INK 2;"The End"
END PROGRAM
|
|
|
|
| Pascalated ZX BASIC Demo #22 - Eagle 1 |
|
Posted by: zarsoft - 07-02-2023, 12:33 PM - Forum: Gallery
- No Replies
|
|
To run online, click here: RUN ONLINE
Code: ' PROGRAM Eagle1 (Lander)
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' 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 PROGRAM REM
#define BEGIN REM
'#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
CONST TRUE TYPE BOOLEAN = 1
CONST FALSE TYPE BOOLEAN = 0
PROGRAM Eagle1
' CONSTant declarations
REM CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST yellow = 6
CONST white = 7
CONST Gravity TYPE REAL = 1.62 ' gravity on the moon
CONST K TYPE REAL = 0.25
CONST Thrust TYPE REAL = 1.1
CONST MaxFuel TYPE REAL = 300
' VAR - Global variables
REM VARiable declarations
VAR MinSpeed TYPE REAL = 999
VAR MaxScore TYPE INTEGER = -1
VAR U$(10) ' DIM U$(8,5) : REM Sprites, upper line
VAR V$(10) ' DIM V$(8,5) : REM Sprites, bottom line
VAR x TYPE INTEGER
VAR y TYPE REAL
VAR yy TYPE INTEGER
VAR Fuel TYPE REAL
VAR DY TYPE REAL
VAR Landed TYPE BOOLEAN
VAR Score TYPE INTEGER
VAR T TYPE INTEGER
VAR Message TYPE INTEGER
PROCEDURE TRON (m$ TYPE STRING)
PRINT AT 23,0;INK 5;m$;
PAUSE 0
END PROCEDURE
PROCEDURE GetReady
PRINT AT 11,0;INK 5;"Press 1 to start"
REPEAT
PAUSE 0
UNTIL INKEY$ = "1"
PRINT AT 11,0;INK 5;" "
END PROCEDURE
PROCEDURE Report
IF ABS DY < MinSpeed THEN LET MinSpeed = ABS DY
LET Score = INT(0.5+(2000+Fuel)/(2^ABS DY))
IF Score <= 1 THEN LET Score = 0
IF Score > MaxScore THEN LET MaxScore = Score
PRINT INK 6;AT 1,0;"Height: ";0;" "
PRINT INK 4;AT 3,0;"MinSpeed:";(STR$ MinSpeed+" ")(0 TO 2)
PRINT INK 4;AT 4,0;"MaxScore:";MaxScore;
IF Score = 0
LET m$ = "You fell like a rock!"
LET n$ = "Press 0 to Thrust."
PRINT AT 21,15;OVER 1;PAPER 8;INK 3;" ";
ELSEIF Score < 500
LET m$ = "You are a beginner."
LET n$ = "Try to be an amateur."
PRINT AT 21,15;OVER 1;PAPER 8;INK 6;" ";
ELSEIF Score < 1000
LET m$ = "You are an amateur."
LET n$ = "Try to be a professional."
PRINT AT 21,15;OVER 1;PAPER 8;INK 5;" ";
ELSE
LET m$ = "You are a professional!"
LET n$ = "You are wasting your time here!"
PRINT AT 21,15;OVER 1;PAPER 8;INK 4;" ";
ENDIF
PRINT AT 6,0;INK 3;"Score: ";Score
PRINT AT 8,0;INK 6;m$
PRINT AT 9,0;INK 6;n$
BEEP 0.1,0: BEEP 0.1,20: BEEP 0.1,10
REM wait a few seconds
LET T = PEEK 23672 + 3*50
IF T > 255 THEN LET T = T - 255
REPEAT
PAUSE 1
UNTIL ABS (T - PEEK 23672) < 5
GetReady
PRINT AT 6,0;" "
PRINT AT 8,0;INK 4;" "
PRINT AT 9,0;INK 4;" "
PRINT AT 20,15;" ";
PRINT AT 21,15;" ";
END PROCEDURE
FUNCTION DataStory TYPE STRING
VAR r$ TYPE STRING
IF Message = 1
r$ = "Hello!"
ELSEIF Message = 2
r$ = "Hello!" + CHR(13) + "Do you read me?"
ELSEIF Message = 3
r$ = "This is Dr Helena Russel,"
ELSEIF Message = 4
r$ = "This is Dr Helena Russel," + CHR(13) + "calling Moonbase Alpha."
ELSEIF Message = 5
r$ = "We are in danger:"
ELSEIF Message = 6
r$ = "We are in danger:" + CHR(13) + "Pilot Alan Carter is sick."
ELSEIF Message = 7
r$ = "You need to land the Eagle 1"
ELSEIF Message = 8
r$ = "You need to land the Eagle 1" + CHR(13) + "by remote control."
ELSEIF Message = 9
r$ = "You are our only hope." + CHR(13) + "God help us!"
ENDIF
RETURN r$
END FUNCTION
PROCEDURE ClearStory
PRINT AT 8,0;
PRINT " ";TAB 0;" ";TAB 0;
PRINT " ";TAB 0;" ";TAB 0;
END PROCEDURE
PROCEDURE TellStory
VAR m$ TYPE STRING
ClearStory
m$ = DataStory
PRINT AT 8,0;INK 6;m$
BEEP 0.1,0: BEEP 0.1,20: BEEP 0.1,10
PAUSE 3*50
LET Message = Message + 1
END PROCEDURE
PROCEDURE DrawScreen
PRINT PAPER 2;INK 0;BRIGHT 1;AT 0, 22;" EAGLE 1 "
PRINT INK 6;AT 0,0;"Fuel: ";Fuel;" "
PRINT INK 6;AT 1,0;"Height: ";ABS INT y;" "
PRINT INK 5;AT 2,0;"Speed: ";(STR$ ABS DY+" ")(0 TO 2)
END PROCEDURE
PROCEDURE InitVariables
LET x = 150
LET y = 175-8
LET yy = y
LET Fuel = MaxFuel
LET DY = 0
LET Landed = FALSE
END PROCEDURE
PROCEDURE Lander
VAR lin TYPE INTEGER
VAR ix TYPE INTEGER
InitVariables
DrawScreen
IF MaxScore < 0 THEN GetReady
REPEAT
LET k$ = INKEY$
IF k$ = "0" AND Fuel > 0
BEEP .01,30: LET DY = DY + Thrust : LET Fuel = Fuel - 10
ELSE
BEEP .01,-28
ENDIF
LET DY = DY - K*Gravity : REM Gravity
LET y = y + DY
LET yy = INT(y+0.5)
IF yy < 0 THEN LET yy = 0 : LET Landed = TRUE
IF yy > 175-8 THEN LET yy = 175-8
LET lin = 21-INT (yy/8)
LET ix = 1+yy-8*INT(yy/8)
POKE 23606,88 : POKE 23607,251 : REM Sprite
PRINT AT lin-1,15;U$(ix)(1 TO 5)
PRINT AT lin,15;V$(ix)(1 TO 5)
IF lin > 1 THEN PRINT AT lin-2,15;" "; : IF ABS DY > 8 THEN PRINT AT lin-3,15;" ";
IF lin < 21 THEN PRINT AT lin+1,15;" ";
POKE 23606,0 : POKE 23607,60 : REM ZX Chars
PRINT INK 6;AT 0,0;"Fuel: ";Fuel;" "
PRINT INK 6;AT 1,0;"Height: ";ABS INT y;" "
PRINT INK 5;AT 2,0;"Speed: ";(STR$ ABS DY+" ")(0 TO 2)
UNTIL Landed
Report
END PROCEDURE
PROCEDURE RestoreData (s TYPE INTEGER)
VAR b,r,n TYPE INTEGER
RESTORE
FOR b=1 TO s
FOR r=0 TO 4
READ n
NEXT r
NEXT b
END PROCEDURE
PROCEDURE InitSprites
CONST RAMTOP = 23730 : REM (87,255) = 65367 = 65535-21*8
CONST SIZE = 936 : REM 96*8 + 21*8
CONST NEWTOP = 64599 : REM 65535-936
REM CLEAR 64599
CONST CHARS = 23606 : REM (0,61-1) = 15616-256
CONST CharsUDG = 65368 : REM USR "A" = 65368 = 65536-21*8
CONST CharsSprites = 64600 : REM 65536-21*8-96*8
REM CharsSprites POKE = (344,251)
VAR s,b,r,n TYPE INTEGER
VAR dest TYPE INTEGER
LET Message = 0
TellStory
' INIT STRINGS
FOR s=0 TO 7
LET U$(s+1) = ":12345"
LET V$(s+1) = ":12345"
NEXT s
REM Define Lines
LET n=32
FOR s=0 TO 7
FOR c=0 TO 4
LET U$(s+1)(c+1) = CHR$(n)
LET n = n+1
NEXT c
FOR c=0 TO 4
LET V$(s+1)(c+1) = CHR$(n)
LET n = n+1
NEXT c
NEXT s
REM Define Sprites
FOR s=7 TO 0 STEP -1
TellStory
RestoreData(s)
LET dest = CharsSprites + 2*5*8*s
REM upper line
FOR b=0 TO 7
FOR r=0 TO 4
READ n
POKE dest+b+r*8,n
'TRON("POKE "+STR$ (dest+b+r*8) )
NEXT r
NEXT b
LET dest = dest + 5*8
REM bottom line
FOR b=0 TO 7
FOR r=0 TO 4
READ n
POKE dest+b+r*8,n
'TRON("POKE "+STR$ (dest+b+r*8) )
NEXT r
NEXT b
REM print eagle
POKE 23606,88 : POKE 23607,251 : REM Sprite
PRINT AT 0,15;V$(s+1)(1 TO );
POKE 23606,0 : POKE 23607,60 : REM ZX Chars
'TRON("s "+STR$ s)
NEXT s
' show sprites
IF FALSE
CLS
c = 1
FOR s=0 TO 7
' upper
c = 3-c: PAPER c
PRINT U$(s+1);":";
POKE 23606,88 : POKE 23607,251 : REM Sprite
PRINT U$(s+1)(1 TO );
POKE 23606,0 : POKE 23607,60 : REM ZX Chars
PRINT ":"
' bottom
c = 3-c: PAPER c
PRINT V$(s+1);":";
POKE 23606,88 : POKE 23607,251 : REM Sprite
PRINT V$(s+1)(1 TO );
POKE 23606,0 : POKE 23607,60 : REM ZX Chars
PRINT ":"
NEXT s
PAUSE 0
CLS
ENDIF
END PROCEDURE
PROCEDURE DataSprite
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 01111111, BIN 11111111, BIN 11111111, BIN 11100001
DATA BIN 00011110, BIN 11111111, BIN 11111111, BIN 11111111, BIN 11110111
DATA BIN 01111111, BIN 11111111, BIN 11111111, BIN 11111111, BIN 11111111
DATA BIN 01111111, BIN 11111111, BIN 11111111, BIN 11111111, BIN 11110111
DATA BIN 00011110, BIN 11111111, BIN 11111111, BIN 11111111, BIN 11100001
DATA BIN 00000000, BIN 00011110, BIN 00000000, BIN 00001111, BIN 00000000
DATA BIN 00000000, BIN 00001100, BIN 00000000, BIN 00000110, BIN 00000000
DATA BIN 00000000, BIN 00011110, BIN 00000000, BIN 00001111, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
END PROCEDURE
PROCEDURE LoadBackground
BORDER 0 : PAPER 0 : INK 7 : CLS
LOAD "" SCREEN$
END PROCEDURE
PROGRAM Eagle1
REM CLEAR 64599
POKE 23606,0 : POKE 23607,60 : REM ZX Chars
PRINT AT 23,0;INK 3;"Pascalated Boriel ZX BASIC demo";
PAUSE 2*50
LoadBackground
InitSprites
ClearStory
REPEAT
Lander
UNTIL FALSE
GameOver
END PROGRAM
|
|
|
|
| Pascalated ZX BASIC Demo #21 - Fxy Graph |
|
Posted by: zarsoft - 06-24-2023, 01:46 PM - Forum: Gallery
- No Replies
|
|
To run online, click here: RUN ONLINE
Try these:
2*(x*x+y*y<1.5)
(x*x+y*y<1.5)*(2-x*x-y*y)
Code: ' PROGRAM ViewFxy
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' 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 PROGRAM REM
#define BEGIN REM
'#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
CONST TRUE TYPE BOOLEAN = 1
CONST FALSE TYPE BOOLEAN = 0
PROGRAM ViewFxy
' CONSTant declarations
REM CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST yellow = 6
CONST white = 7
CONST res TYPE INTEGER = 20 ' resolution
CONST zoom TYPE REAL = 10 ' resize
' VAR - Global variables
VAR nfunc TYPE INTEGER = 1 ' active function number
REM Fxy = VAL ("F"+STR$ nfunc)
VAR F$ TYPE STRING = "0.5*COS(ABS(x*y*12))"
VAR G$ TYPE STRING ' USER function (only X and Y accepted)
VAR X,Y TYPE REAL ' x,y of the PROCEDURE
VAR Z TYPE REAL ' z = f(x,y)
VAR Horizon(255) TYPE INTEGER ' horizon
VAR x1,y1, x2,y2 TYPE REAL ' view domain
VAR TheEnd TYPE BOOLEAN
PROCEDURE TRON (m TYPE STRING)
PRINT AT 23,0;m;
PAUSE 0
END PROCEDURE
FUNCTION VARaz (V$ TYPE STRING) TYPE REAL
VAR R TYPE REAL
IF V$ = "Z"
R = Z
ELSE IF V$ = "Y" OR V$ = "y"
R = Y
ELSE IF V$ = "X" OR V$ = "x"
R = X
ENDIF
RETURN R
END FUNCTION
FUNCTION VALx$ (S$ TYPE STRING) TYPE STRING
VAR R$ TYPE STRING
R$ = ""
FOR i = 0 TO LEN S$ -1
IF S$(i) >= "A"
LET R$ = R$ + STR$ VARaz( S$(i) )
ELSE
LET R$ = R$ + S$(i)
ENDIF
NEXT i
RETURN R$
END FUNCTION
PROCEDURE DrawLineYY (sx0 TYPE INTEGER,sy0 TYPE INTEGER,sx TYPE INTEGER,sy TYPE INTEGER)
VAR swap TYPE BOOLEAN
VAR x,y TYPE INTEGER
VAR xi,yi TYPE REAL
VAR xs,ys TYPE INTEGER
VAR aux TYPE INTEGER
VAR dx TYPE REAL
LET swap = FALSE
IF sy0>sy THEN LET swap = TRUE: LET aux = sy0: LET sy0 = sy: LET sy = aux: LET aux = sx0: LET sx0 = sx: LET sx = aux
LET xi = sx0
LET yi = sy0
LET dx = (0.1+sx-sx0-0.1)/(0.1+sy-sy0-0.1)
FOR y = sy0 TO sy
' xi = xi
yi = y
xs = INT (xi+0.5)
ys = y
IF Horizon(xs) < ys THEN LET Horizon(xs) = ys
IF Horizon(xs) > ys THEN LET ys = Horizon(xs)
PLOT xs, ys
LET xi = xi+dx
' LET yi = yi+1
NEXT y
IF swap THEN LET aux = sy0: LET sy0 = sy: LET sy = aux: LET aux = sx0: LET sx0 = sx: LET sx = aux
END PROCEDURE
PROCEDURE DrawLineXX (sx0 TYPE INTEGER,sy0 TYPE INTEGER,sx TYPE INTEGER,sy TYPE INTEGER)
VAR x,y TYPE INTEGER
VAR xi,yi TYPE REAL
VAR xs,ys TYPE INTEGER
VAR dy TYPE REAL
LET xi = sx0
LET yi = sy0
LET dy = (0.1+sy-sy0-0.1)/(sx-sx0)
FOR x = sx0 TO sx
xi = x
xs = x
ys = INT (yi+0.5)
IF Horizon(xs) < ys THEN LET Horizon(xs) = ys
IF Horizon(xs) > ys THEN LET ys = Horizon(xs)
PLOT xs,ys
LET yi = yi+dy
' LET xi = xi+1
NEXT x
END PROCEDURE
PROCEDURE DrawLine (sx0 TYPE INTEGER,sy0 TYPE INTEGER,sx TYPE INTEGER,sy TYPE INTEGER)
IF sx-sx0 >= ABS(sy-sy0) THEN DrawLineXX(sx0,sy0,sx,sy)
IF sx-sx0 < ABS(sy-sy0) THEN DrawLineYY(sx0,sy0,sx,sy)
END PROCEDURE
FUNCTION F0 TYPE REAL
F$ = VALx$( G$ )
RETURN VAL( F$ )
END FUNCTION
FUNCTION F1 TYPE REAL
RETURN 9/(1+8*X*X+8*Y*Y)
END FUNCTION
FUNCTION F2 TYPE REAL
RETURN 9/(1+X*X*8+Y*Y*8)+0.25*COS(X*8+Y*8)
END FUNCTION
FUNCTION F3 TYPE REAL
RETURN -9/(1+8*X*X+8*Y*Y)
END FUNCTION
FUNCTION F4 TYPE REAL
RETURN 1*SIN(X*Y*6)/(X*Y*6+1.3E-5)
END FUNCTION
FUNCTION F5 TYPE REAL
RETURN 1.2*INT(3*(SIN(X*3)*SIN(X*3))*SIN(X*3)*(SIN(Y*3)*SIN(Y*3))*SIN(Y*3))
END FUNCTION
FUNCTION F6 TYPE REAL
RETURN SIN(X*3)*SIN(Y*3)
END FUNCTION
FUNCTION F7 TYPE REAL
RETURN INT(9/(1+8*X*X+8*Y*Y))
END FUNCTION
FUNCTION F8 TYPE REAL
RETURN 15*(X+Y)*EXP((-X*X*3-Y*Y*3))
END FUNCTION
FUNCTION F9 TYPE REAL
RETURN 7*COS(SQR(X*X*64+Y*Y*64))/(1+X*X*16+Y*Y*16)
END FUNCTION
FUNCTION Fxy TYPE REAL
VAR r TYPE REAL
IF nfunc = 0
r = F0
ELSEIF nfunc = 1
r = F1
ELSEIF nfunc = 2
r = F2
ELSEIF nfunc = 3
r = F3
ELSEIF nfunc = 4
r = F4
ELSEIF nfunc = 5
r = F5
ELSEIF nfunc = 6
r = F6
ELSEIF nfunc = 7
r = F7
ELSEIF nfunc = 8
r = F8
ELSEIF nfunc = 9
r = F9
ENDIF
RETURN r
END FUNCTION
PROCEDURE ShowGraph
VAR sx,sy TYPE INTEGER ' ortogonal screen coordinates
VAR sx0,sy0 TYPE REAL ' previous screen coordinates
VAR u,v TYPE INTEGER ' iterations 1 to res
VAR x0,y0 TYPE REAL ' previous x,y
VAR dx,dy TYPE REAL ' increment
VAR i TYPE INTEGER
BORDER 0 : PAPER 1 : INK 7 : CLS
PRINT "Function ";nfunc
IF nfunc = 0 THEN PRINT "F(x,y)= ";G$
REM DIM Horizon(255) : REM reset horizon
FOR i = 0 TO 255
Horizon(i) = 0
NEXT i
LET y0 = y1
LET dy = (y2-y1)/res
LET Y = y0
FOR v = 1 TO res
LET u = 0
LET x0 = x1
LET dx = (x2-x1)/res
LET X = x0
Z = Fxy ' LET z = F1(x,y)
LET sx0 = 52 + 10*u - INT(2.5*v)
LET sy0 = 0 + INT(2.5*v) + INT(2.5*u) + INT(zoom*Z)
LET Y = Y+dy
FOR u = 1 TO res
LET X = X+dx
Z = Fxy ' LET z = F(x,y)
LET sx = 52 + 10*u - INT(2.5*v)
LET sy = 0 + INT(2.5*v) + INT(2.5*u) + INT(zoom*Z)
' PLOT sx,sy ' OK
' PLOT sx0,sy0: DRAW sx-sx0,sy-sy0 ' OK
' DrawLine(sx0,sy0,sx,sy)
DrawLine( INT (0.5+sx0), INT (0.5+sy0), INT (0.5+sx), INT (0.5+sy) )
LET sx0 = sx
LET sy0 = sy
IF INKEY$ <> "" THEN u = res
NEXT u : REM for x
IF INKEY$ <> "" THEN v = res
NEXT v : REM for y
END PROCEDURE
PROCEDURE WaitKey
PRINT AT 0,0;"Press any key to continue"
PAUSE(0)
END PROCEDURE
PROCEDURE ShowMenu
CLS
PRINT "MENU"
PRINT
PRINT "0 - Input function"
PRINT "1 - 9/(1+8*x*x+8*y*y)"
PRINT "2 - 9/(1+x*x*8+y*y*8)+0.25*COS(x*8+y*8)"
PRINT "3 - -9/(1+8*x*x+8*y*y)"
PRINT "4 - 1*SIN(x*y*6)/(x*y*6+1.3E-5)"
PRINT "5 - 1.2*INT(3*(SIN(x*3)*SIN(x*3))*SIN(x*3)*(SIN(y*3)*SIN(y*3))*SIN(y*3))"
PRINT "6 - SIN(x*3)*SIN(y*3)"
PRINT "7 - INT(9/(1+8*x*x+8*y*y))"
PRINT "8 - 15*(x+y)*EXP((-x*x*3-y*y*3))"
PRINT "9 - 7*COS(SQR(x*x*64+y*y*64))/(1+x*x*16+y*y*16)"
PRINT "Q - Quit"
PRINT
PRINT "Your command: "
END PROCEDURE
PROCEDURE ReadOption
LET TheEnd = FALSE
REPEAT
REPEAT
PAUSE(50)
LET k$ = INKEY$
UNTIL k$ <> ""
UNTIL (k$ >= "0" AND k$ <= "9") OR (k$ = "q")
IF k$ = "q" THEN LET TheEnd = TRUE
IF k$ <> "q" THEN LET nfunc = VAL(k$) ' : LET Fxy = VAL ("F"+STR$ nfunc)
IF nfunc = 0 THEN PRINT ,,"Only X and Y accepted.","You cannot use functions.","F(x,y)= "; : G$ = INPUT(80)
END PROCEDURE
PROCEDURE DefineFirstGraph
LET nfunc = 1
' LET Fxy = VAL ("F"+STR$ nfunc)
LET x1 = -PI/2: LET y1 = -PI/2
LET x2 = PI/2: LET y2 = PI/2
END PROCEDURE
PROGRAM ViewFxy
PRINT AT 23,0;"Pascalated Boriel ZX BASIC demo";
PAUSE 1*50
DefineFirstGraph
REPEAT
ShowGraph
WaitKey
ShowMenu
ReadOption
UNTIL TheEnd
PRINT AT 21,10;INK 2;"The End"
END PROGRAM
|
|
|
|
| VAL incomplete |
|
Posted by: zarsoft - 06-24-2023, 11:54 AM - Forum: Wishlist
- Replies (3)
|
|
In ZX SPECTRUM:
LET x = 2
PRINT VAL "2*x"
Prints 4
But on the compiler gives 0
How about adding variables from "a" to "z" in VAL?
|
|
|
|
| Pascalated ZX BASIC Demo #20 - Maze Walls |
|
Posted by: zarsoft - 06-17-2023, 04:49 PM - Forum: Gallery
- No Replies
|
|
To run online, click here: RUN ONLINE
Code: ' PROGRAM Maze Walls
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' 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 PROGRAM REM
#define BEGIN REM
'#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
CONST TRUE TYPE BOOLEAN = 1
CONST FALSE TYPE BOOLEAN = 0
PROGRAM MazeWalls
' CONSTant declarations
REM CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST yellow = 6
CONST white = 7
'CONST b$ = "\::" ' wall char
CONST cx =127 ' center of horizon
CONST cy =55
CONST DOV = 9 ' depth of vision
CONST FOV = 1+2*(DOV-1): REM field of view (odd number)
' VAR - Global variables
VAR SIZE TYPE INTEGER ' 1..4 user input
VAR MazeLen TYPE INTEGER ' in build maze
VAR Maze$(33) TYPE STRING ' Maze$(33,33)
VAR Key$ TYPE CHAR ' key
VAR Heading TYPE INTEGER ' heading of view
VAR ExitLin TYPE INTEGER ' exit line heading
VAR ExitCol TYPE INTEGER ' exit line heading
VAR Lin,Col TYPE INTEGER ' current position
VAR Walls$(22) TYPE STRING ' Walls$(22,32) walls picture
VAR Holes$(22) TYPE STRING ' Holes$(22,32) holes picture
VAR LinesCoord(10,2) TYPE INTEGER ' lines walls coordinates
VAR ColsCoord(10,4) TYPE INTEGER ' columns walls coordinates
VAR Abort TYPE BOOLEAN
VAR TheEnd TYPE BOOLEAN
VAR b$ = "\::" ' wall char --- should be CONST
VAR f$ TYPE STRING
VAR g$ TYPE STRING
PROCEDURE TRON (m TYPE STRING)
PRINT AT 23,0;m;
PAUSE 0
END PROCEDURE
PROCEDURE Congratulations
PRINT AT 11,12;INK 3;"SUCCESS!"
: FOR i=-11 TO 11: BEEP .01,i: BEEP .01,ABS(i): NEXT i
PRINT AT 23,0;INK 1;" Press any key. ";TAB 31;
PAUSE 5*50
END PROCEDURE
PROCEDURE Help
BORDER 4: PAPER 4: INK 1: CLS
FOR n = 1 TO 22
PRINT AT n-1,0;Maze$(n)(0 TO 31);
NEXT n
PRINT AT Lin-1,Col-1;
IF Heading = 1 THEN PRINT INK 2;">";
IF Heading = 2 THEN PRINT INK 2;"^";
IF Heading = 3 THEN PRINT INK 2;"<";
IF Heading = 4 THEN PRINT INK 2;"V";
IF ExitLin-1 <= 21 AND ExitCol-1 <= 31 THEN PRINT AT ExitLin-1,ExitCol-1;PAPER 8;INK 2;"$";
PRINT AT 23,0;INK 1;"Press any key to continue";TAB 31;
PAUSE 0
PRINT AT 23,0;" ";TAB 31;
BORDER 5: PAPER 5
END PROCEDURE
PROCEDURE ShowFrontWall (base TYPE INTEGER)
INK 5
IF base = 10
PRINT AT 13,15;INK 7;"\A\A";
ELSEIF base = 8
PRINT AT 12,14;INK 7;f$(1 TO 4);
PRINT AT 13,14;INK 7;f$(1 TO 4);
PRINT AT 14,14;INK 7;g$(1 TO 4);
ELSEIF base = 6
FOR l = 10 TO 14
PRINT AT l,12;INK 7;f$(1 TO 8);
NEXT l
PRINT AT 15,12;INK 7;g$(1 TO 8);
ELSEIF base = 4
FOR l = 7 TO 16
PRINT AT l,9;INK 7;f$(1 TO 14);
NEXT l
ELSEIF base = 2
FOR l = 3 TO 18
PRINT AT l,5;INK 7;f$(1 TO 22);
NEXT l
ENDIF
END PROCEDURE
PROCEDURE ShowLeftWay (base TYPE INTEGER)
FOR l = 1 TO 22
PRINT AT l-1,ColsCoord(base,1)-1;PAPER 8;INK 7;Holes$(l)( ColsCoord(base,1) TO ColsCoord(base,2) );
NEXT l
END PROCEDURE
PROCEDURE ShowRightWay (base TYPE INTEGER)
FOR l = 1 TO 22
PRINT AT l-1,ColsCoord(base,3)-1;PAPER 8;INK 7;Holes$(l)( ColsCoord(base,3) TO ColsCoord(base,4) );
NEXT l
END PROCEDURE
PROCEDURE ShowLeftWall (base TYPE INTEGER)
FOR l = 1 TO 22
PRINT AT l-1,ColsCoord(base,1)-1;PAPER 8;INK 6;Walls$(l)( ColsCoord(base,1) TO ColsCoord(base,2) );
NEXT l
END PROCEDURE
PROCEDURE ShowRightWall (base TYPE INTEGER)
FOR l = 1 TO 22
PRINT AT l-1,ColsCoord(base,3)-1;PAPER 8;INK 6;Walls$(l)( ColsCoord(base,3) TO ColsCoord(base,4) );
NEXT l
END PROCEDURE
PROCEDURE ClearScreen
BORDER 0: PAPER 1: INK 7: CLS
PAPER 4: INK 4
PRINT AT 14, 0;PAPER 1;f$(1 TO 12);PAPER 4;" ";TAB 20;PAPER 1;f$(1 TO 12);
PRINT AT 15, 0;PAPER 1;f$(1 TO 9);PAPER 4;" ";TAB 23;PAPER 1;f$(1 TO 9);
PRINT AT 16, 0;PAPER 1;f$(1 TO 9);PAPER 4;" ";TAB 23;PAPER 1;f$(1 TO 9);
PRINT AT 17, 0;PAPER 1;f$(1 TO 5);PAPER 4;" ";TAB 27;PAPER 1;f$(1 TO 5);
PRINT AT 18, 0;PAPER 1;f$(1 TO 5);PAPER 4;" ";TAB 27;PAPER 1;f$(1 TO 5);
PRINT AT 19, 0;" ";TAB 31;" ";
PRINT AT 20, 0;" ";TAB 31;" ";
PRINT AT 21, 0;" ";TAB 31;" ";
PRINT AT 22, 0;" ";TAB 31;" ";
PRINT AT 23, 0;PAPER 0;" ";TAB 31;" ";
END PROCEDURE
PROCEDURE ShowWalls1
VAR range TYPE INTEGER
VAR base TYPE INTEGER
VAR EndShow TYPE BOOLEAN
VAR test TYPE BOOLEAN
REM CLS
PRINT AT 23,0;INK 1;" 58OP-Turn 7Q-Go H-Help A-Abort ";
LET range=0: LET base = 2
LET EndShow = FALSE
REPEAT
LET test = Maze$(Lin-1)(Col+range-1) = b$
IF test THEN ShowLeftWall(base)
IF NOT test THEN ShowLeftWay(base)
LET test = Maze$(Lin+1)(Col+range-1) = b$
IF test THEN ShowRightWall(base)
IF NOT test THEN ShowRightWay(base)
IF Col+range+1 <= MazeLen THEN IF Maze$(Lin)(Col+range+1-1) = b$ THEN ShowFrontWall(base): LET EndShow = TRUE
IF Lin = MazeLen-1 THEN IF Col+range+1 = MazeLen THEN LET EndShow = TRUE
LET Key$ = INKEY$
LET range = range+2: LET base = base+2
UNTIL range=DOV-1 OR EndShow OR Key$<>""
END PROCEDURE
PROCEDURE ShowWalls2
VAR range TYPE INTEGER
VAR base TYPE INTEGER
VAR EndShow TYPE BOOLEAN
VAR test TYPE BOOLEAN
REM CLS
PRINT AT 23,0;INK 1;" 58OP-Turn 7Q-Go H-Help A-Abort ";
LET range=0: LET base = 2
LET EndShow = FALSE
REPEAT
LET test = Maze$(Lin-range)(Col-1-1) = b$
IF test THEN ShowLeftWall(base)
IF NOT test THEN ShowLeftWay(base)
LET test = Maze$(Lin-range)(Col+1-1) = b$
IF test THEN ShowRightWall(base)
IF NOT test THEN ShowRightWay(base)
IF Lin-range-1 >= 1 THEN IF Maze$(Lin-range-1)(Col-1) = b$ THEN ShowFrontWall(base): LET EndShow = TRUE
LET Key$ = INKEY$
LET range = range+2: LET base = base+2
UNTIL range=DOV-1 OR EndShow OR Key$<>""
END PROCEDURE
PROCEDURE ShowWalls3
VAR range TYPE INTEGER
VAR base TYPE INTEGER
VAR EndShow TYPE BOOLEAN
VAR test TYPE BOOLEAN
REM CLS
PRINT AT 23,0;INK 1;" 58OP-Turn 7Q-Go H-Help A-Abort ";
LET range=0: LET base = 2
LET EndShow = FALSE
REPEAT
LET test = Maze$(Lin-1)(Col-range-1) = b$
IF test THEN ShowRightWall(base)
IF NOT test THEN ShowRightWay(base)
LET test = Maze$(Lin+1)(Col-range-1) = b$
IF test THEN ShowLeftWall(base)
IF NOT test THEN ShowLeftWay(base)
IF Col-range-1 >= 1 THEN IF Maze$(Lin)(Col-range-1-1) = b$ THEN ShowFrontWall(base): LET EndShow = TRUE
LET Key$ = INKEY$
LET range = range+2: LET base = base+2
UNTIL range=DOV-1 OR EndShow OR Key$<>""
END PROCEDURE
PROCEDURE ShowWalls4
VAR range TYPE INTEGER
VAR base TYPE INTEGER
VAR EndShow TYPE BOOLEAN
VAR test TYPE BOOLEAN
REM CLS
PRINT AT 23,0;INK 1;" 58OP-Turn 7Q-Go H-Help A-Abort ";
LET range=0: LET base = 2
LET EndShow = FALSE
REPEAT
LET test = Maze$(Lin+range)(Col-1-1) = b$
IF test THEN ShowRightWall(base)
IF NOT test THEN ShowRightWay(base)
LET test = Maze$(Lin+range)(Col+1-1) = b$
IF test THEN ShowLeftWall(base)
IF NOT test THEN ShowLeftWay(base)
IF Lin+range+1 <= MazeLen THEN IF Maze$(Lin+range+1)(Col-1) = b$ THEN ShowFrontWall(base): LET EndShow = TRUE
LET Key$ = INKEY$
LET range = range+2: LET base = base+2
UNTIL range=DOV-1 OR EndShow OR Key$<>""
END PROCEDURE
PROCEDURE ShowMazeWalls
ClearScreen
PAPER 8
' PROC VAL("ShowWalls"+STR$ Heading)
IF Heading = 1 THEN ShowWalls1
IF Heading = 2 THEN ShowWalls2
IF Heading = 3 THEN ShowWalls3
IF Heading = 4 THEN ShowWalls4
END PROCEDURE
PROCEDURE ShowMaze
FOR n = 1 TO 24
PRINT AT n-1,0;Maze$(n)(0 TO 31);
NEXT n
PAUSE 50
END PROCEDURE
PROCEDURE GenerateMaze
VAR middle TYPE INTEGER
VAR positions TYPE INTEGER
VAR block TYPE INTEGER
VAR hole TYPE INTEGER
BORDER green: PAPER green: INK black: CLS
'DIM Maze$(33,33)
FOR i=1 TO 33
LET Maze$(i) = ""
NEXT i
LET Maze$(24) = "Maze by tessellation method"
REM SIZE = 1,2,3 or 4
LET MazeLen = 3
REM horizontal borders
LET Maze$(1) = b$+b$+b$
LET Maze$(2) = b$+" "+b$
LET Maze$(3) = b$+b$+b$
ShowMaze
REM Poles
INK blue
FOR i=1 TO SIZE
REM 3 more copies
FOR l=1 TO MazeLen
LET Maze$(l) = Maze$(l)(0 TO MazeLen-1) + Maze$(l)(1 TO MazeLen-1)
NEXT l
ShowMaze
FOR l=2 TO MazeLen
LET Maze$(MazeLen+l-1) = Maze$(l)(0 TO MazeLen-1)
NEXT l
ShowMaze
FOR l=2 TO MazeLen
LET Maze$(MazeLen+l-1) = Maze$(l)
NEXT l
ShowMaze
REM update new size
LET MazeLen = 2*MazeLen-1
LET middle = INT (MazeLen+1)/2
LET positions = INT (middle-1)/2
REM dig 3 holes
LET block = 1+INT (4*RND)
IF NOT block = 1
REM left
LET hole = 2*INT (1+positions*RND)
LET Maze$(middle)(hole-1) = " "
IF middle-1 <= 21 AND hole-1 <= 31 THEN PRINT AT middle-1,hole-1;PAPER yellow;" ";
REM PAUSE 50
ENDIF
IF NOT block = 2
REM right
LET hole = 2*INT (1+positions*RND)
LET Maze$(middle)(MazeLen+1-hole-1) = " "
IF middle-1 <= 21 AND MazeLen+1-hole-1 <= 31 THEN PRINT AT middle-1,MazeLen+1-hole-1;PAPER yellow;" ";
REM PAUSE 50
ENDIF
IF NOT block = 3
REM top
LET hole = 2*INT (1+positions*RND)
LET Maze$(hole)(middle-1) = " "
IF hole-1 <= 21 AND middle-1 <= 31 THEN PRINT AT hole-1,middle-1;PAPER yellow;" ";
REM PAUSE 50
ENDIF
IF NOT block = 4
REM down
LET hole = 2*INT (1+positions*RND)
LET Maze$(MazeLen+1-hole)(middle-1) = " "
IF MazeLen+1-hole-1 <= 21 AND middle-1 <= 31 THEN PRINT AT MazeLen+1-hole-1,middle-1;PAPER yellow;" ";
REM PAUSE 50
ENDIF
PAUSE 50
ShowMaze
NEXT i
REM start & exit
INK black
END PROCEDURE
PROCEDURE Forward
IF Lin=ExitLin AND Col=ExitCol-1 AND Heading = 1 THEN LET TheEnd = TRUE
IF Heading = 1 THEN IF Maze$(Lin)(Col+1-1)=" " THEN LET Col = Col+2
IF Heading = 2 THEN IF Maze$(Lin-1)(Col-1)=" " THEN LET Lin = Lin-2
IF Heading = 3 THEN IF Maze$(Lin)(Col-1-1)=" " THEN LET Col = Col-2
IF Heading = 4 THEN IF Maze$(Lin+1)(Col-1)=" " THEN LET Lin = Lin+2
END PROCEDURE
PROCEDURE TurnLeft
LET Heading = Heading+1
IF Heading>4 THEN LET Heading = 1
END PROCEDURE
PROCEDURE TurnRight
LET Heading = Heading-1
IF Heading<1 THEN LET Heading = 4
END PROCEDURE
PROCEDURE InitGame
BORDER 5: PAPER 5: INK 0
LET TheEnd = FALSE
LET Abort = FALSE
LET Key$=""
REM --- entry point
LET Lin = 2
LET Col = 2
LET Heading = 1
PRINT AT 2-1,2-1;PAPER 8;INK 2;">";
REM --- exit point
LET ExitLin = MazeLen-1
LET ExitCol = MazeLen
LET Maze$(ExitLin)(ExitCol-1) = "$"
IF ExitLin-1 <= 21 AND ExitCol-1 <= 31 THEN PRINT AT ExitLin-1,ExitCol-1;PAPER 8;INK 2;"$";
PAUSE 3*50
END PROCEDURE
PROCEDURE Game
InitGame
REPEAT
ShowMazeWalls
REPEAT
IF Key$ = "" THEN PAUSE 0: LET Key$ = INKEY$
UNTIL Key$ <> ""
IF Key$="7" OR Key$="q" THEN BEEP .1,5: Forward
IF Key$="5" OR Key$="o" THEN BEEP .1,5: TurnLeft
IF Key$="8" OR Key$="p" THEN BEEP .1,5: TurnRight
IF Key$="h" THEN BEEP .1,5: Help
IF Key$="a" THEN BEEP .1,5: LET Abort = TRUE
UNTIL TheEnd OR Abort
IF TheEnd THEN Congratulations
END PROCEDURE
PROCEDURE DefineSprites
VAR a$ TYPE STRING
VAR n TYPE INTEGER
REM A\A#
REM B\B\\ /\CC
REM DE\D\E/ \\FG\F\G
REM H\H-
REM I\I| |J\J
RESTORE ' DataSprites
READ a$
REPEAT
FOR i=0 TO 7
READ n
POKE USR a$+i,n
NEXT i
' PRINT a$;
READ a$
UNTIL a$ = ""
' PAUSE 0
END PROCEDURE
PROCEDURE DataSprites
DATA "\A" : REM A
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA "\B" : REM B
DATA BIN 10000000
DATA BIN 11000000
DATA BIN 11100000
DATA BIN 11110000
DATA BIN 11111000
DATA BIN 11111100
DATA BIN 11111110
DATA BIN 11111111
DATA "\C" : REM C
DATA BIN 00000001
DATA BIN 00000011
DATA BIN 00000111
DATA BIN 00001111
DATA BIN 00011111
DATA BIN 00111111
DATA BIN 01111111
DATA BIN 11111111
DATA "\D" : REM D
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111110
DATA BIN 11111000
DATA BIN 11100000
DATA BIN 10000000
DATA "\E" : REM E
DATA BIN 11111110
DATA BIN 11111000
DATA BIN 11100000
DATA BIN 10000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "\F" : REM F
DATA BIN 01111111
DATA BIN 00011111
DATA BIN 00000111
DATA BIN 00000001
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "\G" : REM G
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 01111111
DATA BIN 00011111
DATA BIN 00000111
DATA BIN 00000001
DATA "\H" : REM H
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "\I" : REM I
DATA BIN 11111110
DATA BIN 11111110
DATA BIN 11111110
DATA BIN 11111110
DATA BIN 11111110
DATA BIN 11111110
DATA BIN 11111110
DATA BIN 11111110
DATA "\J" : REM J
DATA BIN 01111111
DATA BIN 01111111
DATA BIN 01111111
DATA BIN 01111111
DATA BIN 01111111
DATA BIN 01111111
DATA BIN 01111111
DATA BIN 01111111
DATA "\L" : REM blank
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "\L" : REM blank
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA ""
END PROCEDURE
PROCEDURE DefineMazeSize
CLS
PRINT AT 0,9;INK 3;"MAZE WALLS"
PRINT AT 10,0;
PRINT "Difficulty level:"
PRINT
PRINT "1 - Beginner [ 5*5 ]"
PRINT "2 - Amateur [ 9*9 ]": REM 2 * previous - 1
PRINT "3 - Professional [17*17]"
PRINT "4 - Expert [33*33]"
PRINT
PRINT "Pick your poison"
REM INPUT "Size [1..4] ";SIZE
REPEAT
PAUSE 0
LET Key$ = INKEY$
UNTIL Key$ >= "1" AND Key$ <= "4"
BEEP .1,5
LET SIZE = VAL Key$
RANDOMIZE
END PROCEDURE
PROCEDURE MazeGame
BORDER 4: PAPER 4: INK 0: CLS
DefineMazeSize
GenerateMaze
LET b$ = Maze$(1)(1-1)
Game
REPEAT
BORDER 6: PAPER 6: INK 0: CLS
PRINT AT 22,0;INK 7;"(c) 2023 by ZARSOFT";AT 23,10;"Written by ZE OLIVEIRA";
PRINT AT 0,9;INK 3;"MAZE WALLS"
PRINT AT 10,5;"S - Same maze"
PRINT AT 12,5;"N - New Maze"
PRINT AT 14,5;"T - Terminate"
PRINT AT 17,5;INK 1;"Your command ?"
REPEAT
PAUSE 0: LET Key$ = INKEY$
UNTIL Key$="s" OR Key$="n" OR Key$="t"
BEEP .1,5
IF Key$="s" THEN CLS: ShowMaze: Game
IF Key$="n" THEN DefineMazeSize: GenerateMaze: Game
UNTIL Key$="t"
END PROCEDURE
PROCEDURE InitProgram
LET 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\A\A\A"
LET g$ = "\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H\H"
REM walls
REM DIM Walls$(22,32)
LET Walls$(01) = ".\A\A\B\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\C\A\A"
LET Walls$(02) = ".\A\A\A\B\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\C\A\A\A"
LET Walls$(03) = ".\A\A\A\A\B\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\C\A\A\A\A"
LET Walls$(04) = ".\A\A\A\A\I\B\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\C\J\A\A\A\A"
LET Walls$(05) = ".\A\A\A\A\I\A\B\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\C\A\J\A\A\A\A"
LET Walls$(06) = ".\A\A\A\A\I\A\A\B\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\C\A\A\J\A\A\A\A"
LET Walls$(07) = ".\A\A\A\A\I\A\A\A\B\L\L\L\L\L\L\L\L\L\L\L\L\L\L\C\A\A\A\J\A\A\A\A"
LET Walls$(08) = ".\A\A\A\A\I\A\A\A\I\B\L\L\L\L\L\L\L\L\L\L\L\L\C\J\A\A\A\J\A\A\A\A"
LET Walls$(09) = ".\A\A\A\A\I\A\A\A\I\A\B\L\L\L\L\L\L\L\L\L\L\C\A\J\A\A\A\J\A\A\A\A"
LET Walls$(10) = ".\A\A\A\A\I\A\A\A\I\A\A\B\L\L\L\L\L\L\L\L\C\A\A\J\A\A\A\J\A\A\A\A"
LET Walls$(11) = ".\A\A\A\A\I\A\A\A\I\A\A\I\B\L\L\L\L\L\L\C\J\A\A\J\A\A\A\J\A\A\A\A"
LET Walls$(12) = ".\A\A\A\A\I\A\A\A\I\A\A\I\A\B\L\L\L\L\C\A\J\A\A\J\A\A\A\J\A\A\A\A"
LET Walls$(13) = ".\A\A\A\A\I\A\A\A\I\A\A\I\A\I\B\L\L\C\J\A\J\A\A\J\A\A\A\J\A\A\A\A"
LET Walls$(14) = ".\A\A\A\A\I\A\A\A\I\A\A\I\A\I\I\L\L\J\J\A\J\A\A\J\A\A\A\J\A\A\A\A"
LET Walls$(15) = ".\A\A\A\A\I\A\A\A\I\A\A\I\A\D\E\L\L\F\G\A\J\A\A\J\A\A\A\J\A\A\A\A"
LET Walls$(16) = ".\A\A\A\A\I\A\A\A\I\A\A\D\E\L\L\L\L\L\L\F\G\A\A\J\A\A\A\J\A\A\A\A"
LET Walls$(17) = ".\A\A\A\A\I\A\A\A\I\D\E\L\L\L\L\L\L\L\L\L\L\F\G\J\A\A\A\J\A\A\A\A"
LET Walls$(18) = ".\A\A\A\A\I\A\A\D\E\L\L\L\L\L\L\L\L\L\L\L\L\L\L\F\G\A\A\J\A\A\A\A"
LET Walls$(19) = ".\A\A\A\A\I\D\E\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\F\G\J\A\A\A\A"
LET Walls$(20) = ".\A\A\A\D\E\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\F\G\A\A\A"
LET Walls$(21) = ".\A\D\E\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\F\G\A"
LET Walls$(22) = ".\E\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\F"
REM holes
REM DIM Holes$(22,32)
LET Holes$(01) = ".\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L"
LET Holes$(02) = ".\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L"
LET Holes$(03) = ".\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L"
LET Holes$(04) = ".\A\A\A\A\I\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\J\A\A\A\A"
LET Holes$(05) = ".\A\A\A\A\I\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\J\A\A\A\A"
LET Holes$(06) = ".\A\A\A\A\I\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\J\A\A\A\A"
LET Holes$(07) = ".\A\A\A\A\I\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\J\A\A\A\A"
LET Holes$(08) = ".\A\A\A\A\I\A\A\A\I\L\L\L\L\L\L\L\L\L\L\L\L\L\L\J\A\A\A\J\A\A\A\A"
LET Holes$(09) = ".\A\A\A\A\I\A\A\A\I\L\L\L\L\L\L\L\L\L\L\L\L\L\L\J\A\A\A\J\A\A\A\A"
LET Holes$(10) = ".\A\A\A\A\I\A\A\A\I\L\L\L\L\L\L\L\L\L\L\L\L\L\L\J\A\A\A\J\A\A\A\A"
LET Holes$(11) = ".\A\A\A\A\I\A\A\A\I\A\A\I\L\L\L\L\L\L\L\L\J\A\A\J\A\A\A\J\A\A\A\A"
LET Holes$(12) = ".\A\A\A\A\I\A\A\A\I\A\A\I\L\L\L\L\L\L\L\L\J\A\A\J\A\A\A\J\A\A\A\A"
LET Holes$(13) = ".\A\A\A\A\I\A\A\A\I\A\A\I\A\I\L\L\L\L\J\A\J\A\A\J\A\A\A\J\A\A\A\A"
LET Holes$(14) = ".\A\A\A\A\I\A\A\A\I\A\A\I\A\I\I\L\L\J\J\A\J\A\A\J\A\A\A\J\A\A\A\A"
LET Holes$(15) = ".\A\A\A\A\I\A\A\A\I\A\A\I\H\H\L\L\L\L\H\H\J\A\A\J\A\A\A\J\A\A\A\A"
LET Holes$(16) = ".\A\A\A\A\I\A\A\A\I\H\H\H\L\L\L\L\L\L\L\L\H\H\H\J\A\A\A\J\A\A\A\A"
LET Holes$(17) = ".\A\A\A\A\I\A\A\A\I\L\L\L\L\L\L\L\L\L\L\L\L\L\L\J\A\A\A\J\A\A\A\A"
LET Holes$(18) = ".\A\A\A\A\I\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\J\A\A\A\A"
LET Holes$(19) = ".\A\A\A\A\I\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\J\A\A\A\A"
LET Holes$(20) = ".\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L"
LET Holes$(21) = ".\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L"
LET Holes$(22) = ".\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L\L"
REM lines coordinates
REM DIM LinesCoord(10,2)
LET LinesCoord(2,1) = 1: LET LinesCoord(2,2) = 22
LET LinesCoord(4,1) = 4: LET LinesCoord(4,2) = 19
LET LinesCoord(6,1) = 8: LET LinesCoord(6,2) = 17
LET LinesCoord(8,1) = 11: LET LinesCoord(8,2) = 15
LET LinesCoord(10,1) = 14: LET LinesCoord(10,2) = 14
REM columns coordinates
REM DIM ColsCoord(10,4)
LET ColsCoord(2,1) = 1: LET ColsCoord(2,2) = 5: LET ColsCoord(2,3) = 28: LET ColsCoord(2,4) = 32
LET ColsCoord(4,1) = 6: LET ColsCoord(4,2) = 9: LET ColsCoord(4,3) = 24: LET ColsCoord(4,4) = 27
LET ColsCoord(6,1) = 10: LET ColsCoord(6,2) = 12: LET ColsCoord(6,3) = 21: LET ColsCoord(6,4) = 23
LET ColsCoord(8,1) = 13: LET ColsCoord(8,2) = 14: LET ColsCoord(8,3) = 19: LET ColsCoord(8,4) = 20
LET ColsCoord(10,1) = 15: LET ColsCoord(10,2) = 15: LET ColsCoord(10,3) = 18: LET ColsCoord(10,4) = 18
END PROCEDURE
PROGRAM MazeWalls
PRINT AT 23,0;"Pascalated Boriel ZX BASIC demo";
PAUSE 1*50
DefineSprites
InitProgram
MazeGame
END PROGRAM
|
|
|
|
| Pascalated ZX BASIC Demo #19 - Klotski |
|
Posted by: zarsoft - 06-10-2023, 04:19 PM - Forum: Gallery
- No Replies
|
|
To run online, click here: RUN ONLINE
Code: ' PROGRAM Klotski
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' 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 PROGRAM REM
#define BEGIN REM
'#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
CONST TRUE TYPE BOOLEAN = 1
CONST FALSE TYPE BOOLEAN = 0
PROGRAM Klotski
' CONSTant declarations
REM CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST yellow = 6
CONST white = 7
CONST ScreenLin =6
CONST ScreenCol =8
CONST dl =3: REM 4
CONST dc =3: REM 8
CONST MaxM = 199
CONST MinM = 83
' VAR - Global variables
VAR Board$(4) TYPE STRING ' board
VAR Coord(9,2,2) TYPE INTEGER ' coordinates of objects
VAR Sprite$(9,6) TYPE STRING ' photo of objects
VAR PositionLin,PositionCol TYPE INTEGER
VAR Nmove TYPE INTEGER
VAR grabbed TYPE BOOLEAN
VAR abort TYPE BOOLEAN
PROCEDURE TRON (m TYPE STRING)
PRINT AT 23,0;m;
PAUSE 0
END PROCEDURE
PROCEDURE TraceBoard
PRINT AT 11,0;Board$(1);AT 12,0;Board$(2);AT 13,0;Board$(3);AT 14,0;;Board$(4)
END PROCEDURE
PROCEDURE finalization
PRINT AT 2,0;"###**=- CONGRATULATIONS! -=**###"
: FOR i=-11 TO 11: BEEP .01,i: BEEP .01,ABS(i): NEXT i
PRINT AT 23,0;INK magenta;" ";TAB 9;"Press any key";TAB 32;
PAUSE 0:
BEEP .1,5
END PROCEDURE
FUNCTION GetObjectAtCursor TYPE INTEGER
VAR ob TYPE INTEGER
LET ob = VAL Board$(PositionLin)(PositionCol)
RETURN ob
END FUNCTION
PROCEDURE EraseObject (ob TYPE INTEGER)
VAR PosLin, PosCol TYPE INTEGER
LET PosLin = ScreenLin+(Coord(ob,1,1)-1)*dl
LET PosCol = ScreenCol+(Coord(ob,1,2)-1)*dc
FOR l = 1 TO 6
PRINT AT PosLin+l,PosCol;OVER 1;Sprite$(ob,l);
NEXT l
END PROCEDURE
PROCEDURE EraseObjectAtCursor
VAR ob TYPE INTEGER
LET ob = GetObjectAtCursor
EraseObject(ob)
END PROCEDURE
PROCEDURE PrintObject (ob TYPE INTEGER)
VAR PosLin, PosCol TYPE INTEGER
LET PosLin = ScreenLin+(Coord(ob,1,1)-1)*dl
LET PosCol = ScreenCol+(Coord(ob,1,2)-1)*dc
FOR l = 1 TO 6
PRINT AT PosLin+l,PosCol;OVER 1;Sprite$(ob,l);
NEXT l
END PROCEDURE
PROCEDURE MoveObject (key$ TYPE STRING)
VAR ob TYPE INTEGER
ob = GetObjectAtCursor
EraseObjectAtCursor
FOR l = Coord(ob,1,1) TO Coord(ob,2,1)
FOR c = Coord(ob,1,2) TO Coord(ob,2,2)
LET Board$(l)(c) = "0"
NEXT c
NEXT l
IF key$ ="Q"
LET Coord(ob,1,1) = Coord(ob,1,1)-1: LET Coord(ob,2,1) = Coord(ob,2,1)-1:
LET PositionLin = PositionLin-1:
ELSEIF key$="A"
LET Coord(ob,1,1) = Coord(ob,1,1)+1: LET Coord(ob,2,1) = Coord(ob,2,1)+1:
LET PositionLin = PositionLin+1:
ELSEIF key$="O"
LET Coord(ob,1,2) = Coord(ob,1,2)-1: LET Coord(ob,2,2) = Coord(ob,2,2)-1:
LET PositionCol = PositionCol-1:
ELSEIF key$="P"
LET Coord(ob,1,2) = Coord(ob,1,2)+1: LET Coord(ob,2,2) = Coord(ob,2,2)+1:
LET PositionCol = PositionCol+1:
ENDIF
FOR l = Coord(ob,1,1) TO Coord(ob,2,1)
FOR c = Coord(ob,1,2) TO Coord(ob,2,2)
LET Board$(l)(c) = STR$ ob
NEXT c
NEXT l
PrintObject(ob)
LET Nmove = Nmove+1:
PRINT AT 2,0;"Current: ";Nmove
END PROCEDURE
FUNCTION CheckLegalUp TYPE BOOLEAN
VAR l,c TYPE INTEGER
VAR ok TYPE BOOLEAN
VAR ob TYPE INTEGER
ob = GetObjectAtCursor
LET l = Coord(ob,1,1)-1
IF l > 0
LET ok = TRUE
ELSE
LET ok = FALSE
ENDIF
LET c = Coord(ob,1,2):
WHILE (c <= Coord(ob,2,2)) AND ok
IF Board$(l)(c) <> "0" THEN LET ok = FALSE
LET c = c+1
END WHILE
RETURN ok
END FUNCTION
FUNCTION CheckLegalDown TYPE BOOLEAN
VAR l,c TYPE INTEGER
VAR ok TYPE BOOLEAN
VAR ob TYPE INTEGER
ob = GetObjectAtCursor
LET l = Coord(ob,2,1)+1:
IF l < 5
LET ok = TRUE
ELSE
LET ok = FALSE
ENDIF
LET c = Coord(ob,1,2):
WHILE (c <= Coord(ob,2,2)) AND ok
IF Board$(l)(c) <> "0" THEN LET ok = FALSE
LET c = c+1
END WHILE
RETURN ok
END FUNCTION
FUNCTION CheckLegalLeft TYPE BOOLEAN
VAR l,c TYPE INTEGER
VAR ok TYPE BOOLEAN
VAR ob TYPE INTEGER
ob = GetObjectAtCursor
LET c = Coord(ob,1,2)-1:
IF c > 0
LET ok = TRUE
ELSE
LET ok = FALSE
ENDIF
LET l = Coord(ob,1,1):
WHILE (l <= Coord(ob,2,1)) AND ok
IF Board$(l)(c) <> "0" THEN LET ok = FALSE
LET l = l+1
END WHILE
RETURN ok
END FUNCTION
FUNCTION CheckLegalRight TYPE BOOLEAN
VAR l,c TYPE INTEGER
VAR ok TYPE BOOLEAN
VAR ob TYPE INTEGER
ob = GetObjectAtCursor
LET c = Coord(ob,2,2)+1:
IF c < 6
LET ok = TRUE
ELSE
LET ok = FALSE:
ENDIF
LET l = Coord(ob,1,1):
WHILE (l <= Coord(ob,2,1)) AND ok
IF Board$(l)(c) <> "0" THEN LET ok = FALSE
LET l = l+1
END WHILE
RETURN ok
END FUNCTION
FUNCTION CheckLegalMove (key$ TYPE STRING) TYPE BOOLEAN
VAR legal TYPE BOOLEAN
VAR ob TYPE INTEGER
LET legal = FALSE
ob = GetObjectAtCursor
IF key$ = " " OR key$="M"
IF ob > 0
REM IF grabbed THEN EraseObjectAtCursor
LET grabbed = NOT(grabbed):
REM GetObjectAtCursor: PrintObject: REM (ObjectAtCursor)
ENDIF
ELSEIF key$>="A" AND key$<="Z"
IF grabbed
IF ob > 0
IF key$="Q" THEN legal = CheckLegalUp
IF key$="A" THEN legal = CheckLegalDown
IF key$="O" THEN legal = CheckLegalLeft
IF key$="P" THEN legal = CheckLegalRight
ENDIF
ELSE
IF key$="Q" THEN IF PositionLin > 1 THEN LET PositionLin = PositionLin-1:
IF key$="A" THEN IF PositionLin < 4 THEN LET PositionLin = PositionLin+1:
IF key$="O" THEN IF PositionCol > 1 THEN LET PositionCol = PositionCol-1:
IF key$="P" THEN IF PositionCol < 5 THEN LET PositionCol = PositionCol+1:
ENDIF
ELSE IF key$ = "0"
LET abort = TRUE
ENDIF
RETURN legal
END FUNCTION
FUNCTION InputMove TYPE STRING
VAR key$ TYPE STRING
VAR ColorCursor TYPE INTEGER
LET ColorCursor = yellow
IF grabbed THEN LET ColorCursor = red
PRINT AT ScreenLin+(PositionLin-1)*dl+2,ScreenCol+(PositionCol-1)*dc+1;OVER 1;PAPER ColorCursor;INK ColorCursor;" ";
REPEAT
PAUSE 0: LET key$ = INKEY$
REM IF key$=CHR$(27) THEN LET t = "0":
IF key$ > "Z" THEN LET key$ = CHR$(CODE(key$)+CODE("A")-CODE("a"))
UNTIL key$="0" OR key$=" " OR (key$>="A" AND key$<="Z")
BEEP .1,5
REM IF grabbed THEN PRINT "#" ELSE PRINT " "
PRINT AT ScreenLin+(PositionLin-1)*dl+2,ScreenCol+(PositionCol-1)*dc+1;OVER 1;" ";
RETURN key$
END FUNCTION
PROCEDURE initialization
LET abort = FALSE
LET Nmove = 0
LET grabbed = FALSE
LET PositionLin = 3: LET PositionCol = 3
REM board
LET Board$(0) = "......":
LET Board$(1) = ".98076":
LET Board$(2) = ".98076":
LET Board$(3) = ".11355":
LET Board$(4) = ".11244":
REM size of objects
LET Coord(1,1,1) = 3: LET Coord(1,1,2) = 1: LET Coord(1,2,1) = 4: LET Coord(1,2,2) = 2
LET Coord(2,1,1) = 4: LET Coord(2,1,2) = 3: LET Coord(2,2,1) = 4: LET Coord(2,2,2) = 3
LET Coord(3,1,1) = 3: LET Coord(3,1,2) = 3: LET Coord(3,2,1) = 3: LET Coord(3,2,2) = 3
LET Coord(4,1,1) = 4: LET Coord(4,1,2) = 4: LET Coord(4,2,1) = 4: LET Coord(4,2,2) = 5
LET Coord(5,1,1) = 3: LET Coord(5,1,2) = 4: LET Coord(5,2,1) = 3: LET Coord(5,2,2) = 5
LET Coord(6,1,1) = 1: LET Coord(6,1,2) = 5: LET Coord(6,2,1) = 2: LET Coord(6,2,2) = 5
LET Coord(7,1,1) = 1: LET Coord(7,1,2) = 4: LET Coord(7,2,1) = 2: LET Coord(7,2,2) = 4
LET Coord(8,1,1) = 1: LET Coord(8,1,2) = 2: LET Coord(8,2,1) = 2: LET Coord(8,2,2) = 2
LET Coord(9,1,1) = 1: LET Coord(9,1,2) = 1: LET Coord(9,2,1) = 2: LET Coord(9,2,2) = 1
REM photo of objects
REM 1
LET Sprite$(1,1) = "\ .\..\..\..\..\.."
LET Sprite$(1,2) = "\ :\::\::\::\::\::"
LET Sprite$(1,3) = "\ :\::\::\::\::\::"
LET Sprite$(1,4) = "\ :\::\::\::\::\::"
LET Sprite$(1,5) = "\ :\::\::\::\::\::"
LET Sprite$(1,6) = "\ :\::\::\::\::\::"
REM 2
LET Sprite$(2,1) = "\ .\..\.."
LET Sprite$(2,2) = "\ :\::\::"
LET Sprite$(2,3) = "\ :\::\::"
REM 3
LET Sprite$(3,1) = "\ .\..\.."
LET Sprite$(3,2) = "\ :\::\::"
LET Sprite$(3,3) = "\ :\::\::"
REM 4
LET Sprite$(4,1) = "\ .\..\..\..\..\.."
LET Sprite$(4,2) = "\ :\::\::\::\::\::"
LET Sprite$(4,3) = "\ :\::\::\::\::\::"
REM 5
LET Sprite$(5,1) = "\ .\..\..\..\..\.."
LET Sprite$(5,2) = "\ :\::\::\::\::\::"
LET Sprite$(5,3) = "\ :\::\::\::\::\::"
REM 6
LET Sprite$(6,1) = "\ .\..\.."
LET Sprite$(6,2) = "\ :\::\::"
LET Sprite$(6,3) = "\ :\::\::"
LET Sprite$(6,4) = "\ :\::\::"
LET Sprite$(6,5) = "\ :\::\::"
LET Sprite$(6,6) = "\ :\::\::"
REM 7
LET Sprite$(7,1) = "\ .\..\.."
LET Sprite$(7,2) = "\ :\::\::"
LET Sprite$(7,3) = "\ :\::\::"
LET Sprite$(7,4) = "\ :\::\::"
LET Sprite$(7,5) = "\ :\::\::"
LET Sprite$(7,6) = "\ :\::\::"
REM 8
LET Sprite$(8,1) = "\ .\..\.."
LET Sprite$(8,2) = "\ :\::\::"
LET Sprite$(8,3) = "\ :\::\::"
LET Sprite$(8,4) = "\ :\::\::"
LET Sprite$(8,5) = "\ :\::\::"
LET Sprite$(8,6) = "\ :\::\::"
REM 9
LET Sprite$(9,1) = "\ .\..\.."
LET Sprite$(9,2) = "\ :\::\::"
LET Sprite$(9,3) = "\ :\::\::"
LET Sprite$(9,4) = "\ :\::\::"
LET Sprite$(9,5) = "\ :\::\::"
LET Sprite$(9,6) = "\ :\::\::"
REM background
CLS
PRINT AT 0,12;INK 2;"KLOTSKI"
REM PRINT AT 2,0;"Current= ";Nmove
PRINT AT 2,20;"Minimum= ";MinM
PRINT AT 23,0;INK magenta;"QAOP-Move M,SPC-Select 0-Abort";
FOR ob = 1 TO 9 : PrintObject(ob): NEXT ob
END PROCEDURE
PROCEDURE introduction
BORDER 4: PAPER 4: INK 0: CLS
PRINT AT 5,12;INK 2;"KLOTSKI"
PRINT AT 10,0;"Move the big square","from bottom-left to bottom-right"
PRINT AT 23,0;INK magenta;" ";TAB 9;"Press any key";TAB 32;
PAUSE 0
BEEP .1,5
END PROCEDURE
PROCEDURE MainRoutine
VAR key$ TYPE STRING
VAR legal TYPE BOOLEAN
REPEAT
introduction
initialization
REPEAT
key$ = InputMove
legal = CheckLegalMove(key$)
IF legal THEN MoveObject(key$)
UNTIL (Board$(4)(5)="1") OR abort
UNTIL (Board$(4)(5)="1")
IF Board$(4)(5)="1" THEN finalization
END PROCEDURE
PROGRAM Klotski
PRINT AT 23,0;"Pascalated Boriel ZX BASIC demo";
PAUSE 1*50
MainRoutine
END PROGRAM
|
|
|
|
| Pascalated ZX BASIC Demo #18 - The Lost Comic Book |
|
Posted by: zarsoft - 06-03-2023, 11:31 AM - Forum: Gallery
- No Replies
|
|
To run online, click here: RUN ONLINE
Code: ' PROGRAM The Lost Comic Book
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' 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 PROGRAM REM
#define BEGIN REM
'#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
CONST TRUE TYPE BOOLEAN = 1
CONST FALSE TYPE BOOLEAN = 0
PROGRAM The Lost Comic Book
' CONSTant declarations
CONST PHOTO = 100
' STRING CONST not accepted
'CONST TYPE STRING e$ = "................................" : REM empty line
'CONST e$ TYPE STRING = " " : REM empty line
' VAR - Global variables
VAR STATE TYPE INTEGER ' automaton state
VAR a$(99,CODE "Z") ' automaton
VAR GameOver TYPE BOOLEAN
VAR k$ ' key
VAR Empty$ ' empty line
PROCEDURE TRON (m TYPE STRING)
PRINT AT 22,0;m;
PAUSE 0
END PROCEDURE
DATA 5
DATA "You are in the city of Oporto."
DATA "Your mission, if you choose to accept it, is to find..."
DATA "THE LOST COMIC BOOK."
DATA "You must decide: *Accept or *Decline."
DATA ""
DATA 7
DATA "The nearest comic shop is Bye Bye Tintin."
DATA "*Enter this shop or go to the *Next."
DATA ""
DATA 10
DATA "You enter the shop and search for The Lost Comic Book."
DATA "But you find only Tintin comics."
DATA "You have wasted the whole day."
DATA "You must *Give up."
DATA ""
DATA 12
DATA "The next comic shop is The Wing Shop."
DATA "*Enter this shop or go to the *Next."
DATA ""
DATA 20
DATA "You enter the shop and search for The Lost Comic Book."
DATA "But you find only Asterix comics."
DATA "You have wasted the whole day."
DATA "You must *Give up."
DATA ""
DATA 22
DATA "The next shop is in Coimbra."
DATA "You enter the freeway."
DATA "Time is running out."
DATA "You must go *Faster."
DATA ""
DATA 25
DATA "You are in Coimbra."
DATA "The nearest comic shop is Doc Cartoon."
DATA "*Enter this shop or go to the *Next."
DATA ""
DATA 30
DATA "You enter the shop and search for The Lost Comic Book."
DATA "But you find only Marvel comics."
DATA "You have wasted the whole day."
DATA "You must *Give up."
DATA ""
DATA 32
DATA "The next shop is in Lisbon."
DATA "You enter the freeway."
DATA "Time is running out."
DATA "You must go *Faster."
DATA ""
DATA 35
DATA "You are in Lisbon."
DATA "The nearest comic shop is The Thieves Market."
DATA "*Enter this shop or go to the *Next."
DATA ""
DATA 40
DATA "You enter The Thieves Market and search for The Lost Comic Book."
DATA "But you find only The Phantom comics."
DATA "You have wasted the whole day."
DATA "You must *Give up."
DATA ""
DATA 42
DATA "You see Paradise Cafe across the street and remember the good old days..."
DATA "But time is running out - the shops are almost closed."
DATA "*Enter Paradise Cafe or go to the *Next comic shop."
DATA ""
DATA 50
DATA "You enter Paradise Cafe but the place is different than you remembered... there are no girls..."
DATA "Time is running out - the shops are almost closed."
DATA "Take a *Drink or go to the *Next comic shop."
DATA ""
DATA 52
DATA "While you take a drink you notice that the place is filled with young people working on computers..."
DATA "Now you realize that you are in a Cybercafe - the kids are accessing the internet."
DATA "Sudden you have an ideia... and search for comics on the internet."
DATA "You got 2 answers: www.bdportugal.com and www.bazar0.com."
DATA "What link do you choose?"
DATA "*1 - BD Portugal"
DATA "*2 - Bazar0"
DATA ""
DATA 60
DATA "YOU GOT THE LOST COMIC BOOK!"
DATA "That was fast! Long live the internet!"
DATA "You complete the order and *Exit Paradise Cafe..."
DATA ""
DATA 75
DATA "CONGRATULATIONS!"
DATA "YOU ARE THE MAN!"
DATA "See you next time."
DATA ""
DATA 80
DATA "You reach Vile Books but the shop is closed - is out of business..."
DATA "*Move on."
DATA ""
DATA 90
DATA "You run out of time - the shops are closed."
DATA "*Move on."
DATA ""
DATA 95
DATA "You drive away and stop at Vasco da Gama Bridge."
DATA "You think about what are you gonna do."
DATA "*Jump down or *Try again another day..."
DATA ""
DATA 99
DATA " "
DATA "You better go home and get some sleep."
DATA "Try again tomorrow..."
DATA ""
PROCEDURE ReadKey
REPEAT
PAUSE 0
LET k$ = INKEY$
UNTIL k$ <> ""
BEEP .2,5+5*RND
IF k$ >= "a" THEN LET k$ = CHR$( CODE k$ + CODE "A" - CODE "a" )
END PROCEDURE
PROCEDURE LoadPhoto
REM ShowWaitScreen
PRINT AT 0,0;
FOR i = 0 TO 2
PRINT PAPER 1;INK 1;Empty$;
NEXT i
PRINT PAPER 7;INK 0;AT 1,15;"\A\B";
PRINT PAPER 7;INK 0;AT 2,15;"\C\D";
PRINT AT 3,0;
FOR i = 3 TO 15
PRINT PAPER 1;INK 1;Empty$;
NEXT i
REM LOAD pixels
PAPER 8 : INK 8
PRINT AT 2,0;
LOAD STR$(STATE)+"a" CODE
PRINT PAPER 0;INK 0;AT 16,0;Empty$;
REM LOAD ATTR
PRINT AT 15,0;
LOAD STR$(STATE)+"b" CODE
PAPER 0 : INK 7
REM CLEAR message zone
FOR i = 23 TO 16 STEP -1
PRINT AT i,0;Empty$;
NEXT i
PRINT AT 15,0;
END PROCEDURE
PROCEDURE WriteLineOld1
POKE 23692,255 : REM disable scroll message
PRINT
FOR n=1 TO LEN m$
IF m$(n) <> "*"
PRINT m$(n);
ELSE
LET n = n+1
PRINT PAPER 6;INK 0;m$(n);
ENDIF
BEEP .02,10+10*RND
NEXT n
END PROCEDURE
PROCEDURE WriteLine (m$ TYPE STRING)
POKE 23692,24 : REM disable scroll message
PRINT
FOR n=0 TO LEN m$-1
IF m$(n) <> "*" THEN PRINT m$(n);
IF m$(n) = "*" THEN LET n = n+1 : PRINT PAPER 6;INK 0;m$(n);
IF INKEY = "" THEN BEEP .02,10+10*RND
NEXT n
END PROCEDURE
PROCEDURE RestoreMessage
VAR num TYPE INTEGER
VAR line$ TYPE STRING
RESTORE
READ num
WHILE num <> STATE
REPEAT
READ line$
UNTIL line$ = ""
READ num
END WHILE
END PROCEDURE
PROCEDURE WriteMessage
'RESTORE VAL( "Message"+STR$(STATE) )
RestoreMessage
READ m$
WHILE m$ <> ""
WriteLine(m$)
READ m$
END WHILE
END PROCEDURE
PROCEDURE ProcessKey
LET STATE = CODE a$(STATE,CODE k$)
IF STATE > PHOTO
LET STATE = STATE - PHOTO
LoadPhoto
ENDIF
WriteMessage
IF STATE = 75 OR STATE = 99 THEN LET GameOver = TRUE
END PROCEDURE
PROCEDURE DefineChars
REM \A\B
REM \C\D
' "A"
POKE USR "A"+0, BIN 11111111
POKE USR "A"+1, BIN 11000000
POKE USR "A"+2, BIN 11000000
POKE USR "A"+3, BIN 11001010
POKE USR "A"+4, BIN 11100101
POKE USR "A"+5, BIN 11110010
POKE USR "A"+6, BIN 11111001
POKE USR "A"+7, BIN 11111100
' "B"
POKE USR "B"+0, BIN 11111111
POKE USR "B"+1, BIN 00000111
POKE USR "B"+2, BIN 00000111
POKE USR "B"+3, BIN 10100111
POKE USR "B"+4, BIN 01000111
POKE USR "B"+5, BIN 10011111
POKE USR "B"+6, BIN 00111111
POKE USR "B"+7, BIN 01111111
' "C"
POKE USR "C"+0, BIN 11111101
POKE USR "C"+1, BIN 11111000
POKE USR "C"+2, BIN 11110001
POKE USR "C"+3, BIN 11100000
POKE USR "C"+4, BIN 11000001
POKE USR "C"+5, BIN 11000010
POKE USR "C"+6, BIN 11000101
POKE USR "C"+7, BIN 11111111
' "D"
POKE USR "D"+0, BIN 10111111
POKE USR "D"+1, BIN 00011111
POKE USR "D"+2, BIN 10001111
POKE USR "D"+3, BIN 00000111
POKE USR "D"+4, BIN 10000111
POKE USR "D"+5, BIN 01000111
POKE USR "D"+6, BIN 10100111
POKE USR "D"+7, BIN 11111111
END PROCEDURE
PROCEDURE TheEnd
PAUSE 50
WriteLine("9")
PAUSE 50
WriteLine("8")
PAUSE 50
WriteLine("7")
PAUSE 50
WriteLine("6")
PAUSE 50
WriteLine("5")
PAUSE 50
WriteLine("4")
PAUSE 50
WriteLine("3")
PAUSE 50
WriteLine("2")
PAUSE 50
WriteLine("1")
PAUSE 50
WriteLine("0")
PAUSE 50
'NEW
RANDOMIZE USR 0
END PROCEDURE
PROCEDURE InitGame
BORDER 0 : PAPER 0 : INK 7 : CLS
PRINT "THE LOST COMIC BOOK"
PRINT "(c) 2023 Zarsoft"
PRINT "Pascalated Boriel ZX BASIC demo"
POKE 23609,64 : REM keyboard beep
LET GameOver = FALSE
DefineChars
REM automato
'DIM a$(99,CODE "Z")
LET a$(1,CODE "Start") = CHR$(5+PHOTO)
LET a$(5,CODE "Accept") = CHR$(7)
LET a$(5,CODE "Decline") = CHR$(99)
LET a$(7,CODE "Enter") = CHR$(10+PHOTO)
LET a$(7,CODE "Next") = CHR$(12)
LET a$(10,CODE "Give up") = CHR$(99)
LET a$(12,CODE "Enter") = CHR$(20+PHOTO)
LET a$(12,CODE "Next") = CHR$(22+PHOTO)
LET a$(20,CODE "Give up") = CHR$(99)
LET a$(22,CODE "Faster") = CHR$(25+PHOTO)
LET a$(25,CODE "Enter") = CHR$(30+PHOTO)
LET a$(25,CODE "Next") = CHR$(32+PHOTO)
LET a$(30,CODE "Give up") = CHR$(99)
LET a$(32,CODE "Faster") = CHR$(35+PHOTO)
LET a$(35,CODE "Enter") = CHR$(40+PHOTO)
LET a$(35,CODE "Next") = CHR$(42)
LET a$(40,CODE "Give up") = CHR$(99)
LET a$(42,CODE "Enter") = CHR$(50+PHOTO)
LET a$(42,CODE "Next") = CHR$(80+PHOTO)
LET a$(50,CODE "Drink") = CHR$(52)
LET a$(50,CODE "Next") = CHR$(80+PHOTO)
LET a$(52,CODE "1 BD Portugal") = CHR$(60+PHOTO)
LET a$(52,CODE "2 Bazar0") = CHR$(60+PHOTO)
LET a$(60,CODE "Exit") = CHR$(75+PHOTO)
LET a$(80,CODE "Move on") = CHR$(90+PHOTO)
LET a$(90,CODE "Move on") = CHR$(95+PHOTO)
LET a$(95,CODE "Jump") = CHR$(99)
LET a$(95,CODE "Try again") = CHR$(5+PHOTO)
REM Start first screen
LET STATE = 1
LET k$ = "Start"
'CONST TYPE STRING e$ = "................................" : REM empty line
LET Empty$ = " " : REM empty line
ProcessKey
END PROCEDURE
PROCEDURE MainRoutine
InitGame
REPEAT
ReadKey
'PRINT "---";a$(STATE,CODE k$);"==="
'PRINT "---";CODE a$(STATE,CODE k$);"===" : PAUSE 0
IF a$(STATE,CODE k$) > "" THEN ProcessKey
UNTIL GameOver
TheEnd
END PROCEDURE
PROGRAM The Lost Comic Book
PRINT AT 23,0;"Pascalated Boriel ZX BASIC demo";
PAUSE 1*50
MainRoutine
END PROGRAM
|
|
|
|
|
![[Image: Imagem_3ofaKind.jpg]](https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEgqFjDYND9ABjDedKRpv7jZX_F-0heKg7tsbGKZUDUdXRTzDaO5Qt0SR8FBth-FxKWYM5d2Iglvtn04Ce5Q8X_E6utmHA-XHl7nL_Qx85Puu73cnEM8rG4BrDkB8SzDnke12_rbTCX70cowmTCi5jCQML94_y4G2BxRkyEVBkw1qArnNwYnXxaiHTLUxc9L/s320/Imagem_3ofaKind.jpg)
