Welcome, Guest
You have to register before you can post on our site.

Username
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 384
» Latest member: Steventrato
» Forum threads: 1,028
» Forum posts: 6,212

Full Statistics

Online Users
There are currently 645 online users.
» 0 Member(s) | 643 Guest(s)
Bing, Google

Latest Threads
Includes in ASM
Forum: How-To & Tutorials
Last Post: bracckets
04-04-2024, 12:17 AM
» Replies: 2
» Views: 536
Intermittent errors
Forum: Help & Support
Last Post: zarsoft
03-12-2024, 12:39 PM
» Replies: 0
» Views: 309
Store array information i...
Forum: Help & Support
Last Post: rbiondi
03-10-2024, 09:42 PM
» Replies: 0
» Views: 397
ScrollLeft function scrol...
Forum: Bug Reports
Last Post: rbiondi
03-07-2024, 03:57 PM
» Replies: 2
» Views: 790
string.bas errors when co...
Forum: Bug Reports
Last Post: rbiondi
03-01-2024, 10:10 AM
» Replies: 2
» Views: 703
Using Beepola with ZX BAS...
Forum: How-To & Tutorials
Last Post: edtoo
02-29-2024, 09:47 AM
» Replies: 15
» Views: 32,599
Johnny Bravo
Forum: Gallery
Last Post: zarsoft
02-11-2024, 11:20 PM
» Replies: 0
» Views: 468
Compiling +D G+DOS progra...
Forum: ZX Basic Compiler
Last Post: boriel
01-22-2024, 08:32 AM
» Replies: 4
» Views: 8,614
VAL = ? (solved)
Forum: Bug Reports
Last Post: zarsoft
01-03-2024, 11:44 PM
» Replies: 8
» Views: 3,155
Wrong math (solved)
Forum: Bug Reports
Last Post: zarsoft
01-03-2024, 11:38 PM
» Replies: 4
» Views: 1,732

 
  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

Print this item

  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

Print this item

  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

Print this item

  Error: STRING CONSTant (solved)
Posted by: zarsoft - 06-03-2023, 10:06 AM - Forum: Bug Reports - Replies (7)

This line:

CONST E$ TYPE STRING = "..."

Gives this error:

"Initializer expression is not constant."

Print this item

  Compiles OK then crashed
Posted by: Neo-Rio - 05-30-2023, 07:42 AM - Forum: Bug Reports - Replies (2)

Hi,

I've been trying to convert Telengard from Commodore BASIC to Sinclair BASIC - originally targetting a 32K expanded ZX81 for fun

I quickly discovered that although porting the cut-down Vic-20 version of Telengard that I made some years ago (around 26K) into Sinclair BASIC meant that all those wonderful LET and GOTOs had to be included, in addition to carving up each command onto it's own separate line. In addition to that I had to deal with multiple variable clashes (no two-letter string names, no arrays starting from 0, etc). These set-backs in turn pushed the size of the program well above the original 32K in the text file, so the result I achieved so far was hard won - and to be honest it's a little incomplete in some areas and unfinished. I just wanted to see that I had *something* that would work for now.

ZX81 text to program converters were telling me that the program was just too big.
I turned to BASIC compilation. If I can't get this to run on a ZX81, let's try the 48K speccy.

This might have been a good idea, assuming the compiled program may well be smaller than the original BASIC listing, but it would appear that the tape file created is around 48K in size. Upon loading the compiled program into the emulator, crashes are occurring - despite having completed successful compilation of the code. The crashes seem to differ every time I remove/add lines etc - which makes me think that I've found the 48K Speccy's upper limit of memory. Doesn't even work on a 128K speccy though, so I dunno....

Attached is the text file I have been working from. It compiles OK with the command: 
.\zxbc -taB --sinclair teleng.txt

...but the output won't start in the emulator (I'm using FUSE if that makes a difference)
Is the resulting program just too big to ever work? If so, short of hacking the program down further, is there any way to compress it from the compiler options?
If there's any bugs in the compiler (or I have the wrong options), then I suspect you'll find them thanks to this listing.



Attached Files
.txt   teleng.txt (Size: 47.4 KB / Downloads: 137)
Print this item

  Pascalated ZX BASIC Demo #17 - Hangman
Posted by: zarsoft - 05-21-2023, 01:07 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE



Code:
' PROGRAM Hangman
' (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 Hangman

' CONSTant declarations
CONST LastLine = 12
CONST MaxLen = 11

' VARiables
VAR NumWords TYPE INTEGER ' 29
VAR Score = 0 ' score
VAR Total = 0 ' total of games
VAR DataBuild(10,4) TYPE INTEGER ' gallows and body design
VAR MaxPieces TYPE INTEGER ' Hang and body pieces
VAR Success TYPE BOOLEAN
VAR Hanged TYPE BOOLEAN
VAR Npieces TYPE INTEGER
VAR Nchars TYPE INTEGER
VAR Xkeymap(26) TYPE INTEGER
VAR Ykeymap(26) TYPE INTEGER
VAR key$ TYPE CHAR
VAR AnotherGame TYPE BOOLEAN
VAR Word$ TYPE STRING
VAR LenWord TYPE INTEGER

PROCEDURE DataWords
REM  "12345678901"
DATA "ADAPTER"
DATA "ALGORITHM"
DATA "ASSEMBLER"
DATA "ASSEMBLY"
DATA "AUDIO"
DATA "BASIC"
DATA "BOARD"
DATA "BRIGHTNESS"
DATA "BROWSER"
DATA "CALCULATION"
DATA "CALCULATOR"
DATA "CARTRIDGE"
DATA "CASSETTE"
DATA "CHARACTER"
DATA "CIRCUIT"
DATA "COLOR"
DATA "COMMAND"
DATA "COMPILER"
DATA "COMPUTER"
DATA "DATABASE"
DATA "DESIGN"
DATA "DISK"
DATA "DISPLAY"
REM  "DISTRIBUTION"
DATA "DRIVER"
DATA "DYNAMIC"
DATA "EARTH"
DATA "ELECTRICITY"
DATA "ELECTRONIC"
DATA "EMULATOR"
DATA "EXPANSION"
DATA "EXPRESSION"
DATA "EXTERNAL"
DATA "FIRMWARE"
DATA "FLASH"
DATA "FLOPPY"
DATA "FLUXOGRAM"
DATA "FUTURE"
DATA "GENERATOR"
DATA "GOOGLE"
DATA "GRAPHIC"
DATA "HARDWARE"
DATA "HUMANITY"
DATA "INPUT"
DATA "INTEGER"
REM  "INTELLIGENCE"
DATA "INTERFACE"
DATA "INTERNAL"
DATA "INTERNET"
DATA "INTERPRETER"
DATA "ITERATION"
DATA "JOYSTICK"
DATA "KEYBOARD"
DATA "KEYWORD"
DATA "LOADING"
DATA "MAGAZINE"
DATA "MANUAL"
DATA "MEMORY"
DATA "MICRODRIVE"
REM  "MICROPROCESSOR"
DATA "MICROSOFT"
DATA "MNEMONIC"
DATA "MOTHERBOARD"
DATA "MONITOR"
DATA "MOUSE"
DATA "NUMBER"
DATA "OPERATION"
DATA "OUTPUT"
DATA "PARADISE"
DATA "PASCAL"
DATA "PASSWORD"
DATA "PIRACY"
DATA "PLATFORM"
DATA "PORTUGAL"
DATA "POWER"
DATA "PRINTER"
DATA "PROCESSOR"
DATA "PROGRAM"
DATA "RANDOM"
DATA "REAL"
DATA "RESOLUTION"
DATA "RESTART"
DATA "REVISION"
DATA "ROBOT"
DATA "SAVING"
DATA "SCROLL"
DATA "SHUTDOWN"
DATA "SINCLAIR"
DATA "SOFTWARE"
DATA "SOUND"
DATA "SPEAKER"
DATA "SPECTRUM"
DATA "SPREADSHEET"
DATA "STATIC"
DATA "STRING"
DATA "STORAGE"
DATA "TECHNOLOGY"
DATA "TELEVISION"
REM  "UNIORDER"
DATA "UNIX"
DATA "UPGRADE"
DATA "USERNAME"
DATA "VIDEO"
DATA "VIRUS"
DATA "VOLTAGE"
DATA "WIKIPEDIA"
DATA "WINDOWS"
DATA "YOUTUBE"
DATA "ZILOG"
DATA ""
REM  "12345678901"
END PROCEDURE

PROCEDURE ClearKeyboard
FOR j=20 TO 13 STEP -1
  PRINT AT j,5;PAPER 4;"                    ";
NEXT j
END PROCEDURE

PROCEDURE ShowCrowd
FOR k=1 TO LenWord
  PRINT PAPER 8;AT 10,8+2*k;"\A"
  PRINT PAPER 8;AT 11,8+2*k;"\B"
  PRINT PAPER 8;AT 12,8+2*k;"\C"
NEXT k
END PROCEDURE

PROCEDURE ReadChar
: FOR h=10 TO -10 STEP -2 : BEEP .006,h : NEXT h
REPEAT
  REPEAT
    PAUSE 0
    LET key$ = INKEY$
    'PRINT key$
  UNTIL key$ <> ""
  IF key$ > "Z" THEN LET key$ = CHR$( CODE(key$)+CODE("A")-CODE("a") )
UNTIL key$ >= "A" AND key$ <= "Z"
: FOR h=-2 TO 2 STEP 2 : BEEP .006,h : NEXT h
RANDOMIZE
END PROCEDURE

PROCEDURE ShowChar (k TYPE INTEGER)
PRINT PAPER 1;INK 7;AT 9,8+2*k;key$
PRINT PAPER 8;AT 10,8+2*k;"\D"
PRINT PAPER 8;AT 11,8+2*k;"\E"
PRINT PAPER 8;AT 12,8+2*k;"\F"
END PROCEDURE

PROCEDURE Congratulations
VAR h TYPE INTEGER
ClearKeyboard
PRINT AT 4,10;PAPER 5;INK 2;"Congratulations!"
: FOR h=-2 TO 2 STEP 1 : BEEP .1,h : NEXT h
END PROCEDURE

PROCEDURE Hang
VAR k TYPE INTEGER
ClearKeyboard
PRINT AT 4,10;PAPER 5;INK 2;"You lost!"
REM open floor
FOR k = 1 TO 12
  INVERSE 1
  PLOT 36,86+16 : DRAW 12-(k-1), -(k-1)
  INVERSE 0
  PLOT 36,86+16 : DRAW 12-k, -k
  PAUSE 2
NEXT k
REM join legs
FOR k = 6 TO 0 STEP -1
  REM left leg
  INVERSE 1
  PLOT 42,97+16 : DRAW -(k+1), -14+INT ((k+1)/2)
  INVERSE 0
  PLOT 42,97+16 : DRAW -k, -14+INT (k/2)
  REM right leg
  INVERSE 1
  PLOT 44,97+16 : DRAW (k+1), -14+INT ((k+1)/2)
  INVERSE 0
  PLOT 44,97+16 : DRAW k, -14+INT (k/2)
  PAUSE 2
NEXT k
REM join arms
FOR k = 10 TO 0 STEP -1
  REM left arm
  INVERSE 1
  PLOT 42,111+16 : DRAW -(k+1), (k+1)-10
  INVERSE 0
  PLOT 42,111+16 : DRAW -k, k-10
  REM right arm
  INVERSE 1
  PLOT 44,111+16 : DRAW (k+1), (k+1)-10
  INVERSE 0
  PLOT 44,111+16 : DRAW k, k-10
  PAUSE 2
NEXT k
BEEP .5,0 : PAUSE 20 : BEEP .5,0 : PAUSE 20 : BEEP .25,0 : PAUSE 2 : BEEP 1,0
END PROCEDURE

PROCEDURE Build
VAR x1,y1,x2,y2 TYPE INTEGER
'RESTORE
'READ x1,y1,x2,y2
LET x1 = DataBuild(Npieces,1)
LET y1 = DataBuild(Npieces,2)
LET x2 = DataBuild(Npieces,3)
LET y2 = DataBuild(Npieces,4)
LET y1=176-y1+16
LET y2=176-y2+16
PAPER 5
IF y2 > 176
  CIRCLE x1,y1,x2
ELSE
  PLOT x1,y1
  DRAW x2-x1,y2-y1
ENDIF
END PROCEDURE

PROCEDURE InitDataBuild
'VAR DataBuild(10,4) TYPE INTEGER ' Hang and body design
REM vertical
DataBuild(1,1) = 17
DataBuild(1,2) = 103
DataBuild(1,3) = 17
DataBuild(1,4) = 42
REM horizontal
DataBuild(2,1) = 17
DataBuild(2,2) = 42
DataBuild(2,3) = 43
DataBuild(2,4) = 42
REM diagonal
DataBuild(3,1) = 18
DataBuild(3,2) = 52
DataBuild(3,3) = 27
DataBuild(3,4) = 43
REM rope
DataBuild(4,1) = 43
DataBuild(4,2) = 52
DataBuild(4,3) = 43
DataBuild(4,4) = 42
REM head
DataBuild(5,1) = 43
DataBuild(5,2) = 57
DataBuild(5,3) = 5
DataBuild(5,4) = -1
REM tors
DataBuild(6,1) = 43
DataBuild(6,2) = 62
DataBuild(6,3) = 43
DataBuild(6,4) = 78
REM left arm
DataBuild(7,1) = 43
DataBuild(7,2) = 65
DataBuild(7,3) = 33
DataBuild(7,4) = 65
REM right arm
DataBuild(8,1) = 43
DataBuild(8,2) = 65
DataBuild(8,3) = 53
DataBuild(8,4) = 65
REM left leg
DataBuild(9,1) = 43
DataBuild(9,2) = 78
DataBuild(9,3) = 37
DataBuild(9,4) = 90
REM right leg
DataBuild(10,1) = 43
DataBuild(10,2) = 78
DataBuild(10,3) = 49
DataBuild(10,4) = 90
REM MaxPieces
LET MaxPieces = 10
END PROCEDURE

PROCEDURE HideKey
VAR k TYPE INTEGER
REM hide key$
LET k = CODE key$ - CODE "A" + 1
PRINT PAPER 6;INK 4;AT Ykeymap(k),Xkeymap(k);key$;
END PROCEDURE

PROCEDURE ProcessChar
VAR k TYPE INTEGER
VAR NewChar TYPE BOOLEAN
LET Success = FALSE
LET Hanged = FALSE
LET NewChar = FALSE
FOR k=1 TO LenWord
  IF Word$(k) = key$
    LET NewChar = TRUE
    LET Word$(k) = "."
    LET Nchars=Nchars+1
    ShowChar(k)
  ENDIF
NEXT k
IF NOT NewChar
  LET Npieces = Npieces + 1
  Build
ENDIF
HideKey
IF Nchars = LenWord THEN LET Success = TRUE
IF Npieces = MaxPieces THEN LET Hanged = TRUE
END PROCEDURE

PROCEDURE InitScreen
BORDER 0 : PAPER 4 : INK 0 : CLS
FOR j=0 TO LastLine
  PRINT PAPER 5;"                                ";
NEXT j
FOR j=1 TO 26 : REM alphabet
  PRINT PAPER 6;AT Ykeymap(j),Xkeymap(j);CHR$( j + CODE "A" - 1 )
NEXT j
REM start gallows aparatus
PAPER 5
PLOT 32,72+16: DRAW 0,14: DRAW 21,0: DRAW 0,-14
ShowCrowd
PRINT PAPER 0;INK 4;AT 0,0;" ";TAB 12;"HANGMAN";TAB 32;
END PROCEDURE

PROCEDURE SelectWord
RESTORE
FOR j=1 TO INT(1+RND*NumWords)
  READ Word$
NEXT j
LET LenWord = LEN Word$
LET Word$ = "." + Word$ ' ignore 0 index
END PROCEDURE

PROCEDURE InitGame
VAR a$ TYPE STRING
REM number of pieces build
LET Npieces = 0
REM number of chars found
LET Nchars = 0
END PROCEDURE

PROCEDURE DefineChars
VAR t TYPE INTEGER
VAR n TYPE INTEGER
VAR i TYPE INTEGER
LET t=0
'RESTORE
READ b$
'PRINT AT 1,0;"READ ";b$
REPEAT
  FOR i=0 TO 7
    READ n
    POKE USR b$+i,n
  NEXT i
  LET t=t+1
  IF t=1 BEGIN v
    PRINT AT 10,4;b$
  ELSEIF t=2
    PRINT AT 11,4;b$
  ELSEIF t=3
    PRINT AT 12,4;b$
  ELSEIF t=4
    PRINT AT 10,28;b$
  ELSEIF t=5
    PRINT AT 11,28;b$
  ELSEIF t=6
    PRINT AT 12,28;b$
  ENDIF
  READ b$
  PAUSE 10
UNTIL b$ = ""
END PROCEDURE

PROCEDURE DataChars
DATA "\A" : REM A
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00011000
DATA BIN 00111100
DATA BIN 00111100
DATA BIN 00111100
DATA BIN 00011000
DATA BIN 00011000
DATA "\B" : REM B
DATA BIN 00111100
DATA BIN 01111110
DATA BIN 10011001
DATA BIN 10011001
DATA BIN 10011001
DATA BIN 10011001
DATA BIN 10011001
DATA BIN 10011001
DATA "\C" : REM C
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 11100111
DATA "\D" : REM D
DATA BIN 11000011
DATA BIN 10000001
DATA BIN 10011001
DATA BIN 10111101
DATA BIN 10111101
DATA BIN 10111101
DATA BIN 10011001
DATA BIN 10011001
DATA "\E" : REM E
DATA BIN 01111110
DATA BIN 00111100
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA "\F" : REM F
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 00100100
DATA BIN 11100111
DATA ""
END PROCEDURE

PROCEDURE TheEnd
BORDER 7 : PAPER 7 : INK 0 : CLS
PRINT AT 10,0;"Have a nice day!"
PRINT "Goodbye."
END PROCEDURE

PROCEDURE ShowWord
VAR k TYPE INTEGER
FOR k=1 TO LenWord
  LET key$ = Word$(k)
  IF key$ <> "." THEN ShowChar(k)
NEXT k
END PROCEDURE

PROCEDURE AskAnotherGame
ClearKeyboard
ShowWord
PRINT AT 17,8;" Another Game? ";
REPEAT
  ReadChar
  IF key$ > "Z" THEN LET key$ = CHR$( CODE(key$)+CODE("A")-CODE("a") )
UNTIL key$ = "Y" OR key$ = "N"
IF key$ = "Y" THEN
  LET AnotherGame = TRUE
ELSE
  LET AnotherGame = FALSE
ENDIF
END PROCEDURE

PROCEDURE Game
InitGame
SelectWord
InitScreen
REPEAT
  ReadChar
  ProcessChar
UNTIL Success OR Hanged
IF Success
  Congratulations
ELSEIF Hanged
  Hang
ENDIF
END PROCEDURE

PROCEDURE ShowAnimation
VAR a$ TYPE STRING
VAR b$ TYPE STRING
VAR DataAnimation(3) TYPE STRING
DataAnimation(0) = "                     "
DataAnimation(1) =  "\. \  \. \..\..\. \. \  \. \..\..\. \. \  \. \..\..\. \. \  \. "
DataAnimation(2) =  "\:.\..\: \:.\..\: \:'\. \: \: \..\. \:'\.'\: \:.\..\: \:'\. \: "
DataAnimation(3) =  "\: \  \: \: \  \: \: \ '\: \:.\..\: \: \  \: \: \  \: \: \ '\: "
'DATA "                                         "
'DATA ".   . ..... .   . ..... .   . ..... .   ."
'DATA ":...: :...: :'. : : ... :'.': :...: :'. :"
'DATA ":   : :   : :  ': :...: :   : :   : :  ':"
b$ = DataAnimation(0)
FOR j=3 TO 0 STEP -1
  a$ = DataAnimation(j)
  FOR i=1 TO LastLine+j-3
    PRINT AT i,6;a$
    PRINT AT i-1,6;b$
    IF j>0 THEN BEEP .01,20-i*2
  NEXT i
  IF j>0 THEN FOR h=10 TO -10 STEP -2 : BEEP .006,h : NEXT h
NEXT j
END PROCEDURE

PROCEDURE Introduction
BORDER 0 : PAPER 4 : INK 0 : CLS
PAPER 5
FOR j=0 TO 12
  PRINT "                                ";
NEXT j
ShowAnimation
PAPER 8
PRINT AT LastLine+1,6;"Guess the english word"
DefineChars
PRINT
PRINT AT 17,6;"Press [S] to start"
ReadChar
PRINT AT 17,6;"                  "
END PROCEDURE

PROCEDURE InitNumWords
VAR t TYPE INTEGER
VAR b$ TYPE STRING
RESTORE
LET t=0
READ b$
WHILE b$ <> ""
  LET t=t+1
  IF LEN b$ > MaxLen THEN PRINT AT 10,0;INK 2;"ERROR: Word Length > ";MaxLen;" !",b$: PAUSE 0
  READ b$
END WHILE
LET NumWords = t
'PRINT AT 0,0;"NumWords= ";NumWords: PAUSE 0
END PROCEDURE

PROCEDURE InitProgram
VAR a$ TYPE STRING
InitDataBuild
InitNumWords
LET Score = 0 : REM score
LET Total = 0 : REM total of games
REM keyboard coordinates
'DIM Xkeymap(26)
'DIM Ykeymap(26)
LET a$ = ".QWERTYUIOP"
FOR j=1 TO LEN a$-1
  LET k=CODE a$(j) - CODE "A" + 1
  LET Ykeymap(k) = 15
  LET Xkeymap(k) = 4 + 2*j
NEXT j
LET a$ = ".ASDFGHJKL"
FOR j=1 TO LEN a$-1
  LET k=CODE a$(j) - CODE "A" + 1
  LET Ykeymap(k) = 17
  LET Xkeymap(k) = 5 + 2*j
NEXT j
LET a$ = ".ZXCVBNM"
FOR j=1 TO LEN a$-1
  LET k=CODE a$(j) - CODE "A" + 1
  LET Ykeymap(k) = 19
  LET Xkeymap(k) = 6 + 2*j
NEXT j
END PROCEDURE

PROCEDURE MainRoutine
InitProgram
Introduction
REPEAT
  Game
  AskAnotherGame
UNTIL NOT AnotherGame
TheEnd
END PROCEDURE

PROGRAM Hangman
PRINT AT 23,0;"Pascalated Boriel ZX BASIC demo";
PAUSE 1*50
MainRoutine
END PROGRAM

Print this item

  Pascalated ZX BASIC Demo #16 - Fair Shares
Posted by: zarsoft - 05-15-2023, 02:21 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE

Code:
' PROGRAM Fair Shares
' (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 FairShares

' CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST white = 7
CONST MinMoves = 7
CONST LIN = 16 ' line of buckets

' VARiables
VAR Columns(3) TYPE INTEGER ' Columns of buckets
VAR Capacity(3) TYPE INTEGER ' buckets size (capacity)
VAR Quantity(3) TYPE INTEGER ' milk Quantity on bucket
VAR MoveFrom TYPE INTEGER ' move from to
VAR MoveTo TYPE INTEGER ' move from to
VAR Abort TYPE BOOLEAN
VAR TheEnd TYPE BOOLEAN
VAR Nmoves TYPE INTEGER

PROCEDURE CheckEnd
LET TheEnd = TRUE
IF Abort THEN LET TheEnd = FALSE
IF (Nmoves > MinMoves+1)
  LET TheEnd = FALSE
  PRINT AT 4,9;INK magenta;"TOO MUCH MOVES!"
  PRINT AT 5,9;INK magenta;"  Try again.   "
  : FOR i=11 TO -11 STEP -1: BEEP .01,i: BEEP .01,ABS(i): NEXT i
  PRINT AT 23,0;PAPER green;INK 0;"   Press any key to continue";TAB 32;
  PAUSE 10
  PAUSE 10
  PAUSE 0
  BEEP .1,5
ENDIF
END PROCEDURE

PROCEDURE finalization
PRINT AT 4,0; INK magenta;"  ===-- CONGRATULATIONS! --=== "
: FOR i=-11 TO 11: BEEP .01,i: BEEP .01,ABS(i): NEXT i
PRINT AT 23,0;PAPER green;INK 0;TAB 5;"Press any key to exit";TAB 32;
PAUSE 5
PAUSE 5
PAUSE 0
BEEP .1,5
END PROCEDURE

PROCEDURE MoveMilk ' ( MoveFrom, MoveTo )
VAR moved TYPE BOOLEAN
LET moved = FALSE
WHILE Quantity(MoveFrom)>0 AND Quantity(MoveTo)<Capacity(MoveTo)
  LET moved = TRUE
  REM get
  PRINT AT LIN-Quantity(MoveFrom),Columns(MoveFrom);"      ";
  LET Quantity(MoveFrom) = Quantity(MoveFrom)-1
  REM put
  LET Quantity(MoveTo) = Quantity(MoveTo)+1
  PRINT AT LIN-Quantity(MoveTo),Columns(MoveTo);"\::\::\::\::\::\::";
END WHILE
IF moved BEGIN
  LET Nmoves = Nmoves+1
  PRINT AT 2,0;INK 0;"Moves: ";Nmoves
ENDIF
END PROCEDURE

PROCEDURE InputMove ' ( MoveFrom, MoveTo )
' VAR
REM BEGIN
PRINT AT LIN+2,1;PAPER green;INK black;"MOVE FROM... ";
REPEAT
  PAUSE 0
  LET k$ = INKEY$
UNTIL k$ >= "0" AND k$ <= "9"
BEEP .1,5
LET MoveFrom = VAL (k$)
LET k$ = "9"
IF MoveFrom=0 THEN LET Abort = TRUE: LET k$="0"
PRINT AT LIN+2,1;PAPER green;INK black;"MOVE FROM ";MoveFrom;" TO... ";
WHILE NOT(Abort) AND NOT (k$ >= "0" AND k$ <= "3")
  PAUSE 0
  LET k$ = INKEY$
END WHILE
BEEP .1,5
LET MoveTo = VAL k$
IF MoveTo=0 THEN LET Abort = TRUE
IF Abort THEN LET MoveFrom = 1: LET MoveTo = 1
PRINT AT LIN+2,1;PAPER green;INK black;" ";TAB 31;
END PROCEDURE

PROCEDURE InitBackground
REM background
BORDER 4 : PAPER 4 : INK 0 : CLS
BORDER 5 : PAPER 5
FOR n=0 TO LIN
  PRINT ;" ";TAB 32;
NEXT n
REM buckets
PAPER cyan: INK blue
FOR b=1 TO 3
  PRINT AT LIN-0,Columns(b)-1;"\ :\::\::\::\::\::\::\: "
  FOR i = 1 TO Capacity(b)
    PRINT AT LIN-i,Columns(b)-1;"\ :      \: "
  NEXT i
NEXT b
REM milk
PAPER cyan: INK white
FOR i = 1 TO 8
  PRINT AT LIN-i,Columns(1);"\::\::\::\::\::\::"
NEXT i
PRINT AT 0,0;PAPER white;INK red;TAB 10;"FAIR SHARES";TAB 32;
PRINT AT 2,19;INK 0;"Minimum: ";MinMoves
PRINT AT 23,0;PAPER green;INK black;"123 - Select bucket    0 - Abort";
END PROCEDURE

PROCEDURE InitVars
LET TheEnd = FALSE
LET Abort = FALSE
' DIM Quantity(3): REM milk quantity on bucket
LET Quantity(1) = 8
LET Quantity(2) = 0
LET Quantity(3) = 0
LET Nmoves = 0
END PROCEDURE

PROCEDURE Introduction
BORDER black: PAPER black:  INK green: CLS
PRINT AT 0,10;INK 4;"FAIR SHARES"
INK white
PRINT
PRINT
PRINT "You have 3 buckets of milk."
PRINT
PRINT "The buckets hold 8 liter","5 liter, and 3 liter."
PRINT
PRINT "The 8 liter bucket is full","the others empty."
PRINT
PRINT "You must divide the milk into 2 equal portions, by pouring from one bucket to another."
INK blue
PRINT
PRINT
PRINT "This program was inspired by the book: Computer Puzzles - For Spectrum and ZX81 (Ian Stewart and Robin Jones), 1982."
PRINT AT 23,8;INK blue;"Press any key";
PAUSE 0
BEEP .1,5
END PROCEDURE

PROCEDURE InitProgram
'VAR Columns(3) TYPE INTEGER ' REM columns of buckets
LET Columns(1) = 4
LET Columns(2) = 13
LET Columns(3) = 22
'VAR Capacity(3): REM buckets size (capacity)
LET Capacity(1) = 8
LET Capacity(2) = 5
LET Capacity(3) = 3
END PROCEDURE

PROCEDURE Main
InitProgram
REPEAT
  Introduction
  InitVars
  InitBackground
  REPEAT
    InputMove ' (MoveFrom,t)
    IF MoveFrom<>MoveTo THEN MoveMilk ' (MoveFrom,t)
  UNTIL ( Quantity(1) = 4 AND Quantity(2) = 4 ) OR Abort
  CheckEnd
UNTIL TheEnd
finalization
END PROCEDURE

PROGRAM FairShares
PRINT
PRINT "Pascalated Boriel ZX BASIC demo"
PAUSE 1*50
Main
END PROGRAM

Print this item

  Pascalated ZX BASIC Demo #15 - River Crossing
Posted by: zarsoft - 05-06-2023, 07:56 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE



Code:
' PROGRAM River Crossing
' (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 RiverCrossing

' CONSTant declarations
CONST black = 0
CONST blue = 1
CONST green = 4
CONST white = 7

' VARiables
VAR CharsOK TYPE BOOLEAN = FALSE
VAR abort TYPE BOOLEAN
VAR TheEnd TYPE BOOLEAN
VAR Weight$(3) ' Weights of 3 positions ( X 3 animals )
VAR Sprite$(3,3) ' sprites of 3 animals X 3 lines ( X 3 chars )
VAR Location$(3,3,3) ' sprites in 3 positions of 3 animals X 3 lines ( X 3 chars )
VAR position TYPE INTEGER

PROCEDURE RefreshDisplay
REM Location 1 (left)
PRINT AT 16,0;Location$(1,1,1);Location$(1,2,1);Location$(1,3,1);
PRINT AT 17,0;Location$(1,1,2);Location$(1,2,2);Location$(1,3,2);
PRINT AT 18,0;Location$(1,1,3);Location$(1,2,3);Location$(1,3,3);
REM Location 2 (boat)
LET c = 9+1
IF position = 3 THEN LET c = 12+1
PRINT AT 16,c;Location$(2,1,1);Location$(2,2,1);Location$(2,3,1);
PRINT AT 17,c;Location$(2,1,2);Location$(2,2,2);Location$(2,3,2);
PRINT AT 18,c;Location$(2,1,3);Location$(2,2,3);Location$(2,3,3);
REM Location 3 (right)
PRINT AT 16,23;Location$(3,1,1);Location$(3,2,1);Location$(3,3,1);
PRINT AT 17,23;Location$(3,1,2);Location$(3,2,2);Location$(3,3,2);
PRINT AT 18,23;Location$(3,1,3);Location$(3,2,3);Location$(3,3,3);
END PROCEDURE

PROCEDURE MoveBoat
IF position = 1
  FOR c = 9 TO 11
    PRINT AT 19,c;PAPER 5;" ";PAPER 0;INK 5;"\U         \C";
    PRINT AT 18,c;"  ";Location$(2,1,3);Location$(2,2,3);Location$(2,3,3);
    PRINT AT 17,c;"  ";Location$(2,1,2);Location$(2,2,2);Location$(2,3,2);
    PRINT AT 16,c;"  ";Location$(2,1,1);Location$(2,2,1);Location$(2,3,1);
    BEEP .01,20*RND
  NEXT c
ELSE
  FOR c = 11 TO 9 STEP -1
    PRINT AT 19,c;PAPER 0;INK 5;"\U         \C";PAPER 5;" ";
    PRINT AT 18,c;" ";Location$(2,1,3);Location$(2,2,3);Location$(2,3,3);" ";
    PRINT AT 17,c;" ";Location$(2,1,2);Location$(2,2,2);Location$(2,3,2);" ";
    PRINT AT 16,c;" ";Location$(2,1,1);Location$(2,2,1);Location$(2,3,1);" ";
    BEEP .01,20*RND
  NEXT c
ENDIF
LET position = 4-position
END PROCEDURE

PROCEDURE Sink
LET c = 9+1
IF position = 3 THEN LET c = 12+1
REM frame 1
PRINT AT 19,c-1;" ";Location$(2,1,3);Location$(2,2,3);Location$(2,3,3);" ";
PRINT AT 18,c;Location$(2,1,2);Location$(2,2,2);Location$(2,3,2);
PRINT AT 17,c;Location$(2,1,1);Location$(2,2,1);Location$(2,3,1);
PRINT AT 16,c;"         ";
BEEP .01,20*RND
PAUSE 10
REM frame 2
PRINT AT 19,c;Location$(2,1,2);Location$(2,2,2);Location$(2,3,2);
PRINT AT 18,c;Location$(2,1,1);Location$(2,2,1);Location$(2,3,1);
PRINT AT 17,c;"         ";
BEEP .01,20*RND
PAUSE 10
REM frame 3
PRINT AT 19,c;Location$(2,1,1);Location$(2,2,1);Location$(2,3,1);
PRINT AT 18,c;"         ";
PAUSE 10
REM frame 4
PRINT AT 19,c;"         ";
BEEP .01,20*RND
PAUSE 10
END PROCEDURE

PROCEDURE finalization
PRINT AT 7,8;"CONGRATULATIONS!"
PRINT AT 9,8;INK 1;"Press any key.";
: FOR i=-11 TO 11: BEEP .01,i: BEEP .01,ABS(i): NEXT i
PAUSE 5*50
END PROCEDURE

PROCEDURE CheckTheEnd
IF Weight$(3) = ".XXX"
  LET TheEnd = TRUE
ELSEIF (Weight$(2) = ".XXX") OR (Weight$(2) = ".X X")
  LET abort = TRUE
  PRINT AT 7,8;INK 1;"TOO MUCH WEIGHT!"
  Sink
  : FOR i=11 TO 0 STEP -1: BEEP .01,i+2: BEEP .01,i: NEXT i
  PRINT AT 9,3;INK 1;"Try again. Press any key.";
  PAUSE 5*50
ELSEIF (Weight$(1) = ". XX") OR (Weight$(1) = ".XX ") OR (Weight$( 2) = ". XX") OR (Weight$( 2) = ".XX ") OR (Weight$( 3) = ". XX") OR (Weight$( 3) = ".XX ")
  LET abort = TRUE
  PRINT AT 7,8;INK 1;"Yum! Yum! Yum!";
  : FOR i=11 TO 0 STEP -1: BEEP .01,i+2: BEEP .01,i: NEXT i
  PRINT AT 9,8;INK 1;"Press any key.";
  PAUSE 5*50
ENDIF
PRINT AT 7,0;"                                              ";
PRINT AT 9,0;"                                              ";
END PROCEDURE

PROCEDURE PutIntoBoat (animal)
IF Weight$(position)(animal) <> " "
  REM Weights
  LET Weight$(position)(animal) = " "
  LET Weight$(2)(animal) = "X"
  REM sprites
  LET Location$(position,animal,1) = "   "
  LET Location$(position,animal,2) = "   "
  LET Location$(position,animal,3) = "   "
  LET Location$(2,animal,1) = Sprite$(animal,1)
  LET Location$(2,animal,2) = Sprite$(animal,2)
  LET Location$(2,animal,3) = Sprite$(animal,3)
  RefreshDisplay
ENDIF
END PROCEDURE

PROCEDURE TakeOutOfBoat (animal)
IF Weight$(2)(animal) <> " "
  REM Weights
  LET Weight$(2)(animal) = " "
  LET Weight$(position)(animal) = "X"
  REM sprites
  LET Location$(2,animal,1) = "   "
  LET Location$(2,animal,2) = "   "
  LET Location$(2,animal,3) = "   "
  LET Location$(position,animal,1) = Sprite$(animal,1)
  LET Location$(position,animal,2) = Sprite$(animal,2)
  LET Location$(position,animal,3) = Sprite$(animal,3)
  RefreshDisplay
ENDIF
END PROCEDURE

PROCEDURE PutOrTake
VAR animal TYPE INTEGER
REM --- TAKE OUT ---
LET k$="1": REM dummy key just to enter cycle
WHILE (Weight$(2) <> ".   ") AND (k$ >= "1" AND k$ <= "3")
  PRINT AT 9,8;INK 1;"TAKE OUT OF BOAT ?";
  PAUSE 0: LET k$ = INKEY$: BEEP .1,5
  IF k$ >= "1" AND k$ <= "3" THEN  LET animal = CODE(k$)-CODE("0"): TakeOutOfBoat(animal)
END WHILE
REM --- PUT INTO ---
LET k$="1": REM dummy key just to enter cycle
WHILE (Weight$(3) <> ".XXX") AND (Weight$(position) <> ".   ") AND (k$ >= "1" AND k$ <= "3")
  PRINT AT 9,8;INK 1;"PUT INTO BOAT ?   ";
  PAUSE 0: LET k$ = INKEY$: BEEP .1,5
  IF k$ >= "1" AND k$ <= "3" THEN LET animal = CODE(k$)-CODE("0"): PutIntoBoat(animal)
END WHILE
PRINT AT 9,8;"                  ";
END PROCEDURE

PROCEDURE ShowStartAnimals
PRINT AT 16,0;" \A\B\H\I\J   ";
PRINT AT 17,0;" \C\D\K\L\M  \Q";
PRINT AT 18,0;"\E\F\G\N\O\P\R\S\T";
PRINT AT 19,12;PAPER 0;INK 5;"\U         \C";
END PROCEDURE

PROCEDURE inicialization
REM Weights on the 3 positions
' DIM Weight$(3,3): REM Weights on 3 positions X 3 animals
LET Weight$(1) = ".XXX"
LET Weight$(2) = ".   "
LET Weight$(3) = ".   "
REM sprites of the 3 animals
' DIM Sprite$(3,3,3): REM sprites of 3 animals X 3 lines X 3 chars
REM Dog
LET Sprite$(1,1) = " \A\B"
LET Sprite$(1,2) = " \C\D"
LET Sprite$(1,3) = "\E\F\G"
REM Cat
LET Sprite$(2,1) = "\H\I\J"
LET Sprite$(2,2) = "\K\L\M"
LET Sprite$(2,3) = "\N\O\P"
REM mouse
LET Sprite$(3,2) = "  \Q"
LET Sprite$(3,3) = "\R\S\T"
REM sprites on the 3 positions
' DIM Location$(3,3,3,3): REM sprites in 3 positions of 3 animals X 3 lines X 3 chars
' LOCATION 1 (start)
REM Dog
LET Location$(1,1,1) = Sprite$(1,1)
LET Location$(1,1,2) = Sprite$(1,2)
LET Location$(1,1,3) = Sprite$(1,3)
REM Cat
LET Location$(1,2,1) = Sprite$(2,1)
LET Location$(1,2,2) = Sprite$(2,2)
LET Location$(1,2,3) = Sprite$(2,3)
REM Mouse
LET Location$(1,3,1) = Sprite$(3,1)
LET Location$(1,3,2) = Sprite$(3,2)
LET Location$(1,3,3) = Sprite$(3,3)
' CLEAR LOCATION 2 (boat) and 3 (finish)
FOR i = 2 TO 3 ' location
  FOR j = 1 TO 3 ' animal
    FOR k = 1 TO 3 ' store
      LET Location$(i,j,k) = "   "
    NEXT k
  NEXT j
NEXT i
' extra
LET TheEnd = FALSE
LET abort = FALSE
LET position = 3: REM other side of the river
END PROCEDURE

PROCEDURE DefineChars
' RESTORE Sprites
READ b$
REPEAT
  FOR i=0 TO 7
    READ n
    POKE USR b$+i,n
  NEXT i
  ShowStartAnimals
  ' PAUSE 20
  READ b$
UNTIL b$ = ""
LET CharsOK = true
END PROCEDURE

PROCEDURE Sprites
REM Dog
REM  \A\B
REM  \C\D
REM \E\F\G
REM Cat
REM H\I\J
REM \K\L\M
REM \N\O\P
REM mouse
REM   \Q
REM \R\S\T
REM boat
REM \C\U
END PROCEDURE

PROCEDURE SpriteDog
DATA "A"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000001
DATA BIN 00000001
DATA BIN 00000001
DATA BIN 00000001
DATA "B"
DATA BIN 00000000
DATA BIN 10000000
DATA BIN 10000000
DATA BIN 11100000
DATA BIN 11111000
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111110
DATA "C"
DATA BIN 00000011
DATA BIN 00000011
DATA BIN 00000111
DATA BIN 00001111
DATA BIN 00011111
DATA BIN 00111111
DATA BIN 01111111
DATA BIN 11111111
DATA "D"
DATA BIN 11111000
DATA BIN 11110000
DATA BIN 11110000
DATA BIN 11111000
DATA BIN 11111000
DATA BIN 11111000
DATA BIN 11111000
DATA BIN 11110000
DATA "E"
DATA BIN 00000001
DATA BIN 00000001
DATA BIN 00000011
DATA BIN 11000011
DATA BIN 11000011
DATA BIN 11100011
DATA BIN 01111111
DATA BIN 00111111
DATA "F"
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111101
DATA BIN 11111101
DATA BIN 11111110
DATA BIN 11111111
DATA "G"
DATA BIN 11100000
DATA BIN 11000000
DATA BIN 11000000
DATA BIN 10000000
DATA BIN 10000000
DATA BIN 11000000
DATA BIN 11000000
DATA BIN 01100000
END PROCEDURE

PROCEDURE SpriteCat
DATA "H"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00001110
DATA BIN 00010011
DATA "I"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000001
DATA "J"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00100000
DATA BIN 01100000
DATA BIN 11110000
DATA BIN 11110000
DATA "K"
DATA BIN 00000001
DATA BIN 00000001
DATA BIN 00000001
DATA BIN 00000011
DATA BIN 00000010
DATA BIN 00000110
DATA BIN 00001100
DATA BIN 00011001
DATA "L"
DATA BIN 00000011
DATA BIN 00000011
DATA BIN 00000111
DATA BIN 00111111
DATA BIN 01111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA "M"
DATA BIN 11111000
DATA BIN 11111000
DATA BIN 11110000
DATA BIN 11100000
DATA BIN 11100000
DATA BIN 11100000
DATA BIN 11100000
DATA BIN 11100000
DATA "N"
DATA BIN 00010001
DATA BIN 00010001
DATA BIN 00011001
DATA BIN 00001101
DATA BIN 00001111
DATA BIN 00000111
DATA BIN 00000011
DATA BIN 00000001
DATA "O"
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111100
DATA "P"
DATA BIN 11000000
DATA BIN 10000000
DATA BIN 10000000
DATA BIN 10000000
DATA BIN 10000000
DATA BIN 11000000
DATA BIN 11000000
DATA BIN 11100000
END PROCEDURE

PROCEDURE SpriteMouse
DATA "Q"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 01100000
DATA "R"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 01111000
DATA BIN 00000111
DATA "S"
DATA BIN 00000000
DATA BIN 00001111
DATA BIN 00011111
DATA BIN 00011111
DATA BIN 00111111
DATA BIN 00111111
DATA BIN 01111111
DATA BIN 11111111
DATA "T"
DATA BIN 01111100
DATA BIN 11111110
DATA BIN 11111100
DATA BIN 11110000
DATA BIN 11100000
DATA BIN 11000000
DATA BIN 01000000
DATA BIN 00100000
END PROCEDURE

PROCEDURE SpriteBoat
DATA "U"
DATA BIN 10000000
DATA BIN 11000000
DATA BIN 11100000
DATA BIN 11110000
DATA BIN 11111000
DATA BIN 11111100
DATA BIN 11111110
DATA BIN 11111111
END PROCEDURE

PROCEDURE SpritesEnd
DATA ""
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 ""
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
END PROCEDURE

PROCEDURE ShowBackground
REM green
PRINT AT 19,0;PAPER 4;" ";TAB 31;" ";TAB 31;" ";TAB 31;" ";
REM Space for boat
PRINT AT 19,9;PAPER 5;" ";TAB 22;" "
REM River
PRINT AT 20,9;PAPER 1;" ";TAB 22;" "
PRINT AT 21,9;PAPER 1;" ";TAB 22;" "
REM Boat
PRINT AT 19,12;PAPER 0;" ";TAB 18;" "
REM keys
PRINT AT 22,0;PAPER green;" ";TAB 0;PAPER green;"1,2,3 - Take/Put   SPACE - Cross";
END PROCEDURE

PROCEDURE introduction
BORDER 5: PAPER 5: INK 2: CLS
PRINT AT 0,7;INK 2;"THE RIVER CROSSING"
PRINT AT 4,0;INK 1;"You have a mouse, a cat and"
PRINT AT 5,0;INK 1;"a dog..."
PRINT AT 7,0;INK 1;"CROSS THE RIVER..."
PRINT AT 9,0;INK 1;"But don't let them"
PRINT AT 10,0;INK 1;"eat each other!"
END PROCEDURE

PROCEDURE Main
introduction
ShowBackground
IF NOT CharsOK THEN DefineChars
PAUSE 5*50
PRINT AT 4,0;" ",,,,,,,,,,,,," " : REM clean introduction
REPEAT
  inicialization
  RefreshDisplay
  MoveBoat
  REPEAT
    PutOrTake
    IF NOT(abort) THEN MoveBoat
    CheckTheEnd
  UNTIL abort OR TheEnd
UNTIL TheEnd
finalization
END PROCEDURE

PROGRAM RiverCrossing
PRINT
PRINT "Pascalated Boriel ZX BASIC demo"
PAUSE 1*50
Main
END PROGRAM

Print this item

  Pascalated ZX BASIC Demo #14 - Joker
Posted by: zarsoft - 04-29-2023, 04:33 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE


Code:
' PROGRAM Joker
' (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 Joker

' 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

' VARiable declarations
VAR S$(11) TYPE STRING ' scores 1.11
VAR SCORE TYPE INTEGER ' 0..10
VAR Year TYPE INTEGER ' current question
VAR Question$ TYPE STRING ' current question
VAR Correct TYPE INTEGER ' correct answer 1234
VAR Answer TYPE INTEGER ' user answer 1234
VAR NumQuestions TYPE INTEGER

PROCEDURE CountQuestions
PRINT AT 23,0;PAPER 7;INK blue;"Scanning database...";TAB 31;
PAUSE 50
LET NumQuestions = 0
RESTORE
READ Year
REPEAT
  READ Question$
  LET NumQuestions = NumQuestions+1
  READ Year
UNTIL Year <= 0
PRINT AT 23,0;PAPER 7; INK blue;NumQuestions;" questions detected.";TAB 32;
PAUSE 2*50
PRINT AT 23,0;PAPER 7; INK blue;"Press any key";TAB 31;
PAUSE 0: RANDOMIZE
END PROCEDURE

PROCEDURE DataQuestions
DATA 1936,"Alan Turing proposes the Turing Machine"
DATA 1945,"Construction of the ENIAC"
DATA 1947,"Invention of the first transistor"
DATA 1951,"Construction of the UNIVAC I"
DATA 1956,"IBM invents the first commercial hard drive"
DATA 1957,"IBM introduces FORTRAN, high-level computer language"
DATA 1958,"First integrated circuit is created"
DATA 1963,"The Digital Equipment Corporation introduces the minicomputer"
DATA 1963,"Invention of the first mouse"
DATA 1965,"Moore's Law is first proposed"
DATA 1968,"Founding of Intel"
DATA 1969,"Creation of UNIX"
DATA 1970,"Release of the first commercial microprocessor"
DATA 1970,"Release of Pascal structured language"
DATA 1971,"IBM releases the first commercial floppy disk"
DATA 1972,"Release of C programming language"
DATA 1975,"Founding of Microsoft"
DATA 1976,"Founding of Apple"
DATA 1976,"Release of the Electric Pencil"
DATA 1977,"Release of Apple II"
DATA 1979,"Release of the first spreadsheet computer program, VisiCalc"
DATA 1980,"Sinclair ZX80 is launched"
DATA 1981,"IBM releases its first personal computer, which ran MS-DOS"
DATA 1981,"Sinclair ZX81 is launched"
DATA 1982,"Sinclair ZX Spectrum is launched"
DATA 1983,"The CD-ROM hit the market, able to hold 550 megabytes"
DATA 1984,"Sinclair QL is launched"
DATA 1984,"QL arrives with SuperBASIC one of the first structured BASIC languages"
DATA 1984,"IBM develops a one-million bit RAM"
DATA 1984,"Launch of the first PDA"
DATA 1984,"Amstrad launches the CPC464."
DATA 1985,"Microsoft announces Windows"
DATA 1985,"Registration of the first dot-com domain"
DATA 1986,"Amstrad buys Sinclair computers"
DATA 1989,"Launch of the GRIDPad 1900, the first commercially successful tablet computer"
DATA 1990,"Invention of HTML"
DATA 1990,"Launch of the first internet browser"
DATA 1991,"Launch of the first commercial SSD"
DATA 1993,"Release of the NSCA Mosaic web browser"
DATA 1997,"Google Search launched"
DATA 1999,"Nvidia releases the GeForce 256"
DATA 1999,"Wi-Fi becomes widely used"
DATA 2003,"AMD introduces the Athlon 64, the first commercially available 64-bit processor"
DATA 2005,"Launch of YouTube"
DATA 2007,"Apple unveils the first iPhone"
DATA 2008,"Google and HTC launch HTC Dream, the first Android phone"
DATA 2012,"The Raspberry Pi, a credit-card-sized single-board computer is released"
DATA 2016,"The first reprogrammable quantum computer is created"
END PROCEDURE

PROCEDURE DataEnd
DATA -1,""
END PROCEDURE

PROCEDURE LoadKO
PAPER 0: INK 0: PRINT AT 0,0;
POKE 23739,111: REM disable messages
LOAD "KO" SCREEN$
POKE 23739,244: REM restore messages
BORDER 0
END PROCEDURE

PROCEDURE LoadOK
PAPER 0: INK 0: PRINT AT 0,0;
POKE 23739,111: REM disable messages
LOAD "OK" SCREEN$
POKE 23739,244: REM restore messages
BORDER 0
END PROCEDURE

PROCEDURE LoadQuestion
PAPER 0: INK 0: PRINT AT 0,0;
POKE 23739,111: REM disable messages
LOAD "QUESTION" SCREEN$
POKE 23739,244: REM restore messages
BORDER 0
END PROCEDURE

PROCEDURE WriteScore
FOR i=1 TO SCORE
  PRINT AT 21-i,26;PAPER blue;INK white;S$(i+1);"$";
NEXT i
END PROCEDURE

PROCEDURE finalization
PRINT PAPER blue;INK white;AT 23,0;" ";TAB 4;"That's all for today!";TAB 32;
IF SCORE >= 10
  LoadOK
  WriteScore
  PRINT AT 10,0;PAPER cyan;INK black;"         "
  PRINT AT 11,0;PAPER cyan;INK black;"YOU ARE A"
  PRINT AT 12,0;PAPER cyan;INK black;"COMPUTER \..\.."
  PRINT AT 13,0;PAPER cyan;INK black;"         "
  : FOR i=-11 TO 11: BEEP .01,i: BEEP .01,ABS(i): NEXT i
  PAUSE 3*50
ELSEIF SCORE >= 7
  LoadOK
  WriteScore
  PRINT AT 10,0;PAPER green;INK black;"         "
  PRINT AT 11,0;PAPER green;INK black;"CONGRATU-"
  PRINT AT 12,0;PAPER green;INK black;"LATIONS! \''\''"
  PRINT AT 13,0;PAPER green;INK black;"         "
  : FOR i=-11 TO 11: BEEP .01,i: BEEP .01,ABS(i): NEXT i
  PAUSE 3*50
ELSEIF SCORE >= 4
  LoadOK
  WriteScore
  PRINT AT 11,0;PAPER white;INK black;"         "
  PRINT AT 12,0;PAPER white;INK black;"Nice try!\..\.."
  PRINT AT 13,0;PAPER white;INK black;"         "
  : FOR i=-11 TO 11: BEEP .01,i: BEEP .01,ABS(i): NEXT i
  PAUSE 3*50
ELSEIF SCORE >= 1
  LoadKO
  WriteScore
  PRINT AT  9,0;PAPER magenta;INK black;"          "
  PRINT AT 10,0;PAPER magenta;INK black;"You should"
  PRINT AT 11,0;PAPER magenta;INK black;"upgrade   "
  PRINT AT 12,0;PAPER magenta;INK black;"your      \..\.."
  PRINT AT 13,0;PAPER magenta;INK black;"memory!   "
  PRINT AT 14,0;PAPER magenta;INK black;"          "
  : FOR i=11 TO -11 STEP -1: BEEP .01,i: BEEP .01,ABS(i): NEXT i
  PAUSE 3*50
ELSE
  LoadKO
  WriteScore
  PRINT AT 10,0;PAPER red;INK white;"         "
  PRINT AT 11,0;PAPER red;INK white;" You are "
  PRINT AT 12,0;PAPER red;INK white;" a rock! ";INK black;"\''\''"
  PRINT AT 13,0;PAPER red;INK white;"         "
  : FOR i=11 TO -11 STEP -1: BEEP .01,i: BEEP .01,ABS(i): NEXT i
  PAUSE 3*50
ENDIF
PAUSE 0
BORDER white: PAPER white: INK black: CLS
PRINT "Pascalated Boriel ZX BASIC demo"
END PROCEDURE

PROCEDURE CheckAnswer
IF Answer = Correct
  LoadOK
  LET SCORE = SCORE+1
  PRINT AT 11,0;PAPER green;INK black;"        "
  PRINT AT 12,0;PAPER green;INK black;" RIGHT! \..\.."
  PRINT AT 13,0;PAPER green;INK black;"        "
  PRINT AT 21-SCORE,26;PAPER blue;INK white;S$(SCORE+1);"$";
  WriteScore
  : FOR i=-11 TO 11: BEEP .01,i: BEEP .01,ABS(i): NEXT i
ELSE
  LoadKO
  PRINT AT 11,0;PAPER magenta;INK black;"        "
  PRINT AT 12,0;PAPER magenta;INK black;" WRONG! \..\.."
  PRINT AT 13,0;PAPER magenta;INK black;"        "
  PRINT AT 21-SCORE,26;PAPER blue;INK white;S$(SCORE+1);"$";
  WriteScore
  : FOR i=11 TO -11 STEP -1: BEEP .01,i: BEEP .01,ABS(i): NEXT i
ENDIF
PAUSE 1*50
REM PROC finalization: REM test final messages
END PROCEDURE

PROCEDURE InputAnswer
REPEAT
  PAUSE 0: LET k$ = INKEY$
UNTIL k$ >= "1" AND k$ <= "4"
BEEP .1,5
LET Answer = VAL k$
PRINT AT 23,(Answer-1)*8;PAPER magenta;OVER 1;"        ";
RANDOMIZE
END PROCEDURE

PROCEDURE WriteQuestion
VAR segment TYPE INTEGER
REM write question
LET segment = 10
LET k$ = Question$+"          "
LET LinStart = 12-INT(LEN Question$/segment/2+1)
FOR i=1 TO LEN Question$ STEP segment
  PRINT AT LinStart+i/segment,0;PAPER yellow;INK 0;k$(i-1 TO i+segment-1-1);
NEXT i
PRINT AT 12,segment;PAPER yellow;INK 0;"\..\..";
REM write answers
LET Correct = 1+INT(RND*4)
PRINT AT 23,0;
FOR i=1 TO 4
  PRINT " ";PAPER blue;INK white;i;"-";Year-Correct+i;PAPER black;" ";
NEXT i
END PROCEDURE

PROCEDURE SelectQuestion
RESTORE
LET NumQuestion = INT(RND*NumQuestions)
FOR i = 1 TO NumQuestion
  READ Year,Question$
NEXT i
' PRINT AT 0,0;INK 7;"resposta: ";Year
END PROCEDURE

PROCEDURE InitProgram
LET SCORE = 0
'DIM S$(11)
LET S$( 0+1)= "    0"
LET S$( 1+1)= "  100"
LET S$( 2+1)= "  250"
LET S$( 3+1)= "  500"
LET S$( 4+1)= " 1000"
LET S$( 5+1)= " 2500"
LET S$( 6+1)= " 5000"
LET S$( 7+1)= "10000"
LET S$( 8+1)= "25000"
LET S$( 9+1)= "50000"
LET S$(10+1)= "75000"
CountQuestions
:FOR i=-11 TO 11: BEEP .01,i: BEEP .01,ABS(i): NEXT i
BORDER 0
END PROCEDURE

PROCEDURE Game
InitProgram
FOR i=1 TO 10
  LoadQuestion
  WriteScore
  SelectQuestion
  WriteQuestion
  InputAnswer
  CheckAnswer
NEXT i
finalization
END PROCEDURE

PROGRAM Joker
PRINT
PRINT "Pascalated Boriel ZX BASIC demo"
PAUSE 1*50
BORDER 7: PAPER 7: INK 0: CLS
LOAD "SPLASH" SCREEN$
BORDER white
PAUSE 2*50
PAPER 0
Game
END PROGRAM

Print this item

  No more loading messages (solved)
Posted by: zarsoft - 04-29-2023, 01:00 PM - Forum: Help & Support - Replies (2)

On ZX Spectrum we can do this to disable loading messages:


Code:
POKE 23739,111: REM disable messages
LOAD "KO" SCREEN$
POKE 23739,244: REM restore messages


How can I do that on ZX BASIC compiler?

Print this item