Forum
Portal

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

Username
  

Password
  

Search Forums

(Advanced Search)

Forum Statistics
» Members: 259
» Latest member: Jeffreybub
» Forum threads: 1,074
» Forum posts: 6,434

Full Statistics

Online Users
There are currently 253 online users.
» 0 Member(s) | 250 Guest(s)
Applebot, Bing, Google

Latest Threads
.tap file code not execut...
Forum: Help & Support
Last Post: Zoran
04-28-2025, 10:59 AM
» Replies: 4
» Views: 178
Exit from more than one l...
Forum: Wishlist
Last Post: Duefectu
04-23-2025, 10:06 PM
» Replies: 3
» Views: 254
put small ASM programs li...
Forum: How-To & Tutorials
Last Post: Zoran
04-18-2025, 02:02 PM
» Replies: 6
» Views: 1,504
Creating +3 Menus - Loadi...
Forum: Help & Support
Last Post: merlinkv
04-16-2025, 02:08 PM
» Replies: 6
» Views: 511
Randomize not very random...
Forum: Help & Support
Last Post: Zoran
04-08-2025, 10:40 AM
» Replies: 4
» Views: 414
Scope rules
Forum: Bug Reports
Last Post: Zoran
04-04-2025, 09:46 AM
» Replies: 2
» Views: 284
Using constants not allow...
Forum: Bug Reports
Last Post: baltasarq
03-19-2025, 10:00 PM
» Replies: 8
» Views: 1,002
404 page not found
Forum: Documentation
Last Post: boriel
03-08-2025, 07:16 PM
» Replies: 5
» Views: 2,839
Spectrum keywords codes
Forum: Bug Reports
Last Post: boriel
03-08-2025, 11:00 AM
» Replies: 1
» Views: 389
ZXodus][Engine
Forum: ZX Basic Compiler
Last Post: boriel
02-19-2025, 11:43 PM
» Replies: 69
» Views: 213,410

 
  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

  Pascalated ZX BASIC Demo #13 - Memory
Posted by: zarsoft - 04-23-2023, 05:37 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE


Code:
' PROGRAM Memory
' (c) Starsoft 2022 Pascalated BASIC
' (c) Starsoft 2023 Pascalated Boriel ZX BASIC
' Written by David Magalhaes
' 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 Memory

' CONSTant declarations
CONST npositions TYPE INTEGER = 15
CONST ncards TYPE INTEGER = 52

' VAR - Global variables
VAR DECK(52,2) TYPE INTEGER ' 52 cards, suit, value
VAR KEYMAP(128) TYPE INTEGER ' keyboard to card number
VAR numPairs TYPE INTEGER ' number of card pairs
VAR POSITION(20,3) TYPE INTEGER ' position and id of cards (lin, col, card)
VAR card1 TYPE INTEGER ' first selected card
VAR card2 TYPE INTEGER ' second selected card
VAR STATE TYPE INTEGER ' number of cards face-up
VAR v$ TYPE CHAR ' card value on top
VAR w$ TYPE CHAR ' card value on bottom
VAR s$ TYPE CHAR ' card suit on top
VAR t$ TYPE CHAR ' card suit on bottom
VAR KEYS$ TYPE STRING ' keys to identify cards

PROCEDURE RemoveCard (p TYPE INTEGER)
LET POSITION(p,3) = 0
POKE 23659,1: REM 23 lines
POKE 23606,88: POKE 23607,251: REM sprites
PRINT AT POSITION(p,1)+0,POSITION(p,2); PAPER 0;"     ";
PRINT AT POSITION(p,1)+1,POSITION(p,2); PAPER 0;"     ";
PRINT AT POSITION(p,1)+2,POSITION(p,2); PAPER 0;"     ";
PRINT AT POSITION(p,1)+3,POSITION(p,2); PAPER 0;"     ";
PRINT AT POSITION(p,1)+4,POSITION(p,2); PAPER 0;"     ";
PRINT AT POSITION(p,1)+5,POSITION(p,2); PAPER 0;"     ";
PRINT AT POSITION(p,1)+6,POSITION(p,2); PAPER 0;"     ";
POKE 23606,0: POKE 23607,60: REM ZX Chars
POKE 23659,2: REM 22 lines
END PROCEDURE

PROCEDURE RemoveCards
FOR p=1 TO npositions
  RemoveCard(p)
NEXT p
END PROCEDURE

PROCEDURE PrintBack (p TYPE INTEGER)
POKE 23659,1: REM 23 lines
POKE 23606,88: POKE 23607,251: REM sprites
PRINT AT POSITION(p,1)+0,POSITION(p,2); INK 1;".....";
PRINT AT POSITION(p,1)+1,POSITION(p,2); INK 1;".....";
PRINT AT POSITION(p,1)+2,POSITION(p,2); INK 1;".....";
PRINT AT POSITION(p,1)+3,POSITION(p,2); INK 1;".....";
PRINT AT POSITION(p,1)+4,POSITION(p,2); INK 1;".....";
PRINT AT POSITION(p,1)+5,POSITION(p,2); INK 1;".....";
PRINT AT POSITION(p,1)+6,POSITION(p,2); INK 1;".....";
POKE 23606,0: POKE 23607,60: REM ZX Chars
POKE 23659,2: REM 22 lines
END PROCEDURE

PROCEDURE PrintBacks
BORDER 0: PAPER 0: INK 7: CLS
PAPER 7: INK 2
FOR p=1 TO npositions
  PrintBack(p)
  BEEP .02,20*RND
NEXT p
END PROCEDURE

PROCEDURE PrintCard1 (p TYPE INTEGER)
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;"    ";
PRINT AT POSITION(p,1)+1,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+3,POSITION(p,2);"  "+s$+"  ";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+5,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+6,POSITION(p,2);"    ";w$;
END PROCEDURE

PROCEDURE PrintCard2 (p TYPE INTEGER)
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;"    ";
PRINT AT POSITION(p,1)+1,POSITION(p,2);"  ";s$;"  ";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+3,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+5,POSITION(p,2);"  ";t$;"  ";
PRINT AT POSITION(p,1)+6,POSITION(p,2);"    ";w$;
END PROCEDURE

PROCEDURE PrintCard3 (p TYPE INTEGER)
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;"    ";
PRINT AT POSITION(p,1)+1,POSITION(p,2);"  ";s$;"  ";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+3,POSITION(p,2);"  ";s$;"  ";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+5,POSITION(p,2);"  ";t$;"  ";
PRINT AT POSITION(p,1)+6,POSITION(p,2);"    ";w$;
END PROCEDURE

PROCEDURE PrintCard4 (p TYPE INTEGER)
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;"    ";
PRINT AT POSITION(p,1)+1,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+3,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+5,POSITION(p,2);" ";t$;" ";t$;" ";
PRINT AT POSITION(p,1)+6,POSITION(p,2);"    ";w$;
END PROCEDURE

PROCEDURE PrintCard5 (p TYPE INTEGER)
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;"    ";
PRINT AT POSITION(p,1)+1,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+3,POSITION(p,2);"  ";s$;"  ";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+5,POSITION(p,2);" ";t$;" ";t$;" ";
PRINT AT POSITION(p,1)+6,POSITION(p,2);"    ";w$;
END PROCEDURE

PROCEDURE PrintCard6 (p TYPE INTEGER)
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;"    ";
PRINT AT POSITION(p,1)+1,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+3,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+5,POSITION(p,2);" ";t$;" ";t$;" ";
PRINT AT POSITION(p,1)+6,POSITION(p,2);"    ";w$;
END PROCEDURE

PROCEDURE PrintCard7 (p TYPE INTEGER)
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;"    ";
PRINT AT POSITION(p,1)+1,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"  ";s$;"  ";
PRINT AT POSITION(p,1)+3,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+5,POSITION(p,2);" ";t$;" ";t$;" ";
PRINT AT POSITION(p,1)+6,POSITION(p,2);"    ";w$;
END PROCEDURE

PROCEDURE PrintCard8 (p TYPE INTEGER)
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;"    ";
PRINT AT POSITION(p,1)+1,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"  ";s$;"  ";
PRINT AT POSITION(p,1)+3,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"  ";t$;"  ";
PRINT AT POSITION(p,1)+5,POSITION(p,2);" ";t$;" ";t$;" ";
PRINT AT POSITION(p,1)+6,POSITION(p,2);"    ";w$;
END PROCEDURE

PROCEDURE PrintCard9 (p TYPE INTEGER)
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;"    ";
PRINT AT POSITION(p,1)+1,POSITION(p,2);" ";s$;s$;s$;" ";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+3,POSITION(p,2);" ";s$;s$;s$;" ";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"     ";
PRINT AT POSITION(p,1)+5,POSITION(p,2);" ";t$;t$;t$;" ";
PRINT AT POSITION(p,1)+6,POSITION(p,2);"    ";w$;
END PROCEDURE

PROCEDURE PrintCard10 (p TYPE INTEGER)
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;"    ";
PRINT AT POSITION(p,1)+1,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+2,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+3,POSITION(p,2);" ";s$;" ";s$;" ";
PRINT AT POSITION(p,1)+4,POSITION(p,2);" ";t$;" ";t$;" ";
PRINT AT POSITION(p,1)+5,POSITION(p,2);" ";t$;" ";t$;" ";
PRINT AT POSITION(p,1)+6,POSITION(p,2);"    ";w$;
END PROCEDURE

PROCEDURE PrintCard11 (p TYPE INTEGER)
REM jack
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;" /01";
PRINT AT POSITION(p,1)+1,POSITION(p,2);s$;" 234";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"56789";
PRINT AT POSITION(p,1)+3,POSITION(p,2);":;<=>";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"?@ABC";
PRINT AT POSITION(p,1)+5,POSITION(p,2);"DEF ";t$;
PRINT AT POSITION(p,1)+6,POSITION(p,2);"GHI ";w$;
END PROCEDURE

PROCEDURE PrintCard12 (p TYPE INTEGER)
REM queen
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;" JKL";
PRINT AT POSITION(p,1)+1,POSITION(p,2);s$;" MNO";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"PQRST";
PRINT AT POSITION(p,1)+3,POSITION(p,2);"UVWXY";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"Z[\\]^";
PRINT AT POSITION(p,1)+5,POSITION(p,2);"_`a ";t$;
PRINT AT POSITION(p,1)+6,POSITION(p,2);"bcd ";w$;
END PROCEDURE

PROCEDURE PrintCard13 (p TYPE INTEGER)
REM king
PRINT AT POSITION(p,1)+0,POSITION(p,2);v$;" efg";
PRINT AT POSITION(p,1)+1,POSITION(p,2);s$;" hij";
PRINT AT POSITION(p,1)+2,POSITION(p,2);"klmno";
PRINT AT POSITION(p,1)+3,POSITION(p,2);"pqrst";
PRINT AT POSITION(p,1)+4,POSITION(p,2);"uvwxy";
PRINT AT POSITION(p,1)+5,POSITION(p,2);"z{| ";t$;
PRINT AT POSITION(p,1)+6,POSITION(p,2);"}~\* ";w$;
END PROCEDURE

PROCEDURE PrintCard (p TYPE INTEGER)
VAR card TYPE INTEGER
VAR suit TYPE INTEGER
VAR cor TYPE INTEGER
VAR value TYPE INTEGER
POKE 23659,1: REM 23 lines
POKE 23606,88: POKE 23607,251: REM sprites
LET card = POSITION(p,3)
LET suit = DECK(card,1)
LET cor = 2*(suit>2)
LET cor = 0
IF suit>2 THEN LET cor = 2
LET value=DECK(card,2)
LET s$ = CHR$ ( CODE ("\L") + 2*suit)
LET t$ = CHR$ ( CODE ("\L") + 2*suit+1)
LET v$ = CHR$ ( CODE ("\A") - 1+value)
LET w$ = CHR$ ( CODE (" ") + value)
INK cor
IF     value = 1
  PrintCard1(p)
ELSEIF value = 2
  PrintCard2(p)
ELSEIF value = 3
  PrintCard3(p)
ELSEIF value = 4
  PrintCard4(p)
ELSEIF value = 5
  PrintCard5(p)
ELSEIF value = 6
  PrintCard6(p)
ELSEIF value = 7
  PrintCard7(p)
ELSEIF value = 8
  PrintCard8(p)
ELSEIF value = 9
  PrintCard9(p)
ELSEIF value = 10
  PrintCard10(p)
ELSEIF value = 11
  PrintCard11(p)
ELSEIF value = 12
  PrintCard12(p)
ELSEIF value = 13
  PrintCard13(p)
ENDIF
POKE 23606,0: POKE 23607,60: REM ZX Chars
POKE 23659,2: REM 22 lines
END PROCEDURE

PROCEDURE PrintCards
FOR p=1 TO npositions
  IF POSITION(p,3) > 0 THEN PrintCard(p)
NEXT p
END PROCEDURE

PROCEDURE DealCards
VAR randomCard TYPE INTEGER
VAR randomPosition TYPE INTEGER
VAR UsedCards(ncards) TYPE BOOLEAN
VAR card TYPE INTEGER
PRINT AT 23,10;PAPER 0;"Please wait";
BEEP .05,20
PAUSE 25
'FOR i = 1 TO ncards
'  UsedCards(i) = FALSE
'NEXT i'
LET numPairs = INT(npositions/2)
'DIM UsedCards(ncards)
FOR p=1 TO numPairs
  REM LET POSITION(p,3)=1+INT (ncards*RND)
  REPEAT
    LET randomCard = 1+INT (ncards*RND)
  UNTIL UsedCards(randomCard ) = FALSE
  LET UsedCards(randomCard ) = TRUE
  REM Place card
  REPEAT
    LET randomPosition = 1+INT (npositions*RND)
  UNTIL POSITION(randomPosition,3) = 0
  LET POSITION(randomPosition,3) = randomCard
  REM Place other card
  REPEAT
    LET randomPosition = 1+INT (npositions*RND)
  UNTIL POSITION(randomPosition,3) = 0
  LET POSITION(randomPosition,3) = randomCard
NEXT p
' remove position card not used
LET card = 0
REPEAT
  LET card = card + 1
UNTIL POSITION(card,3) = 0
RemoveCard(card)
PRINT AT 23,10;PAPER 0;"           ";
END PROCEDURE

PROCEDURE testPair
IF POSITION(card1,3) <> POSITION(card2,3)
  PrintBack(card1)
  PrintBack(card2)
ELSE
  LET numPairs = numPairs - 1
  RemoveCard(card1)
  RemoveCard(card2)
  FOR i = 1 TO 20 STEP 10: BEEP .02,20: BEEP .02,20*RND: NEXT i
ENDIF
END PROCEDURE

PROCEDURE Success
PAPER 0: INK 4: CLS
REM PRINT AT 10,10; "SUCCESS!"
PRINT AT 8,1; "\::\::\:: \:: \:: \::\::\:: \::\::\:: \::\::\:: \::\::\:: \::\::\:: \::"
PRINT AT 9,1; "\::   \:: \:: \::   \::   \::   \::   \::   \::"
PRINT AT 10,1; "\::\::\:: \:: \:: \::   \::   \::\::\:: \::\::\:: \::\::\:: \::"
PRINT AT 11,1; "  \:: \:: \:: \::   \::   \::     \::   \::"
PRINT AT 12,1; "\::\::\:: \::\::\:: \::\::\:: \::\::\:: \::\::\:: \::\::\:: \::\::\:: \::"
FOR i = 1 TO 20: BEEP .02,i: BEEP .02,20*RND: NEXT i
PAUSE 5*50
END PROCEDURE

PROCEDURE PrintIndex
POKE 23659,1: REM 23 lines
FOR p = 1 TO npositions
  PRINT AT POSITION(p,1)+6,POSITION(p,2)-1; PAPER 0; INK 1;KEYS$(p);
NEXT p
POKE 23659,2: REM 22 lines
END PROCEDURE

PROCEDURE InitVariables
VAR c TYPE INTEGER
VAR s TYPE INTEGER
VAR v TYPE INTEGER
REM keyboard index
POKE 23658,8: REM upper case
LET KEYS$="X12345QWERTASDFG"
LET j$="12345qwertasdfg"
REM keymap - keyboard to card number
'DIM KEYMAP(128)
LET KEYMAP( CODE "1")=1
LET KEYMAP( CODE "2")=2
LET KEYMAP( CODE "3")=3
LET KEYMAP( CODE "4")=4
LET KEYMAP( CODE "5")=5
LET KEYMAP( CODE "Q")=6
LET KEYMAP( CODE "W")=7
LET KEYMAP( CODE "E")=8
LET KEYMAP( CODE "R")=9
LET KEYMAP( CODE "T")=10
LET KEYMAP( CODE "A")=11
LET KEYMAP( CODE "S")=12
LET KEYMAP( CODE "D")=13
LET KEYMAP( CODE "F")=14
LET KEYMAP( CODE "G")=15
REM deck
'DIM DECK(52,2) ' 52 cards, suit, value
LET c=0
FOR s=1 TO 4
  FOR v=1 TO 13
    LET c=c+1
    LET DECK(c,1) = s: LET DECK(c,2) = v
  NEXT v
NEXT s
'LET ncards = c
REM positions
' DIM POSITION(20,3): REM (lin, col, card)
REM part 1
LET POSITION(1,1)=0: LET POSITION(1,2)=1
LET POSITION(2,1)=0: LET POSITION(2,2)=7
LET POSITION(3,1)=0: LET POSITION(3,2)=13
LET POSITION(4,1)=0: LET POSITION(4,2)=19
LET POSITION(5,1)=0: LET POSITION(5,2)=25
REM part 2
LET POSITION(6,1)=8: LET POSITION(6,2)=1
LET POSITION(7,1)=8: LET POSITION(7,2)=7
LET POSITION(8,1)=8: LET POSITION(8,2)=13
LET POSITION(9,1)=8: LET POSITION(9,2)=19
LET POSITION(10,1)=8: LET POSITION(10,2)=25
REM part 3
LET POSITION(11,1)=16: LET POSITION(11,2)=1
LET POSITION(12,1)=16: LET POSITION(12,2)=7
LET POSITION(13,1)=16: LET POSITION(13,2)=13
LET POSITION(14,1)=16: LET POSITION(14,2)=19
LET POSITION(15,1)=16: LET POSITION(15,2)=25
LET STATE = 0 : REM 0: 0 cards face-up, 1: 1 card face-up
LET card1 = 0 : REM first card selected
LET card2 = 0 : REM second card selected
END PROCEDURE

PROCEDURE Game
VAR p TYPE INTEGER
VAR legal TYPE BOOLEAN
PrintBacks
DealCards
REM POKE 23659,1
PrintIndex
REM PrintCards
FOR i = 1 TO 20 STEP 5: BEEP .02,i: BEEP .02,20*RND: NEXT i
REPEAT
  PAUSE 0: LET k$=INKEY$: BEEP .1,20
  IF k$<>""
    LET p = KEYMAP( CODE k$)
    LET legal = TRUE
    IF p = 0 THEN LET legal = FALSE
    IF legal THEN IF POSITION(p,3) = 0 THEN LET legal = FALSE
    IF legal
      IF STATE = 0
        LET card1 = p : PrintCard(p)
        LET STATE = 1
      ELSEIF STATE = 1 and p <> card1
        LET card2 = p : PrintCard(p)
        pause 1*50
        testPair
        LET STATE = 0
      ENDIF
    ENDIF
  ENDIF
UNTIL numPairs = 0
Success
END PROCEDURE

PROCEDURE WaitForUser
CLS
PRINT AT 11,5; INK 3; "PRESS ANY KEY TO START"
BEEP .05,20
PAUSE 0
PRINT AT 11,5; INK 3; "   Shuffling Deck...  "
RANDOMIZE
BEEP .1,20
PAUSE 25
END PROCEDURE

PROCEDURE LoadSprites
PRINT AT 18,0;
LOAD "sprites" CODE 64600
END PROCEDURE

PROCEDURE SaveSprites
SAVE "sprites" CODE 64600,2^16-64600
END PROCEDURE

PROCEDURE Main
' LoadSprites
WaitForUser
InitVariables
REPEAT
  Game
UNTIL FALSE
END PROCEDURE

BEGIN
REM CLEAR 64599
REM PRINT "Demo for Pascalated BASIC"
POKE 23606,0: POKE 23607,60: REM ZX Chars
PRINT AT 0,0;"Starsoft presents"
BEEP .05,20
PAUSE 50
PRINT "Memory"'''
BEEP .05,20
PAUSE 50
Main
END
Print this item

  Pascalated ZX BASIC Demo #12 - Dogfight David
Posted by: zarsoft - 04-15-2023, 03:01 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE


Code:
' PROGRAM Dogfight David
' (c) Starsoft 2022 Pascalated BASIC
' (c) Starsoft 2023 Pascalated Boriel ZX BASIC
' 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 Dogfight David

' CONSTant declarations
CONST DX TYPE INTEGER = 1 ' index for automaton for moveForward
CONST DY TYPE INTEGER = 2 ' index for automaton for moveForward

' VAR - Global variables
REM boolean GAMEOVER
VAR player1COL TYPE INTEGER
VAR player1LIN TYPE INTEGER
VAR player1COL0 TYPE INTEGER
VAR player1LIN0 TYPE INTEGER
VAR player2COL TYPE INTEGER
VAR player2LIN TYPE INTEGER
VAR player2COL0 TYPE INTEGER
VAR player2LIN0 TYPE INTEGER
VAR DirectionP1 TYPE INTEGER
VAR DirectionP2 TYPE INTEGER
VAR missile1COL TYPE INTEGER
VAR missile1LIN TYPE INTEGER
VAR missile1COL0 TYPE INTEGER
VAR missile1LIN0 TYPE INTEGER
VAR missile2COL TYPE INTEGER
VAR missile2LIN TYPE INTEGER
VAR missile2COL0 TYPE INTEGER
VAR missile2LIN0 TYPE INTEGER
VAR DirectionM1 TYPE INTEGER
VAR missile1Fuel TYPE INTEGER
VAR DirectionM2 TYPE INTEGER
VAR missile2Fuel TYPE INTEGER
VAR Sprite$(8) TYPE STRING ' automaton for plane image
VAR KeyMap(13,2,2) TYPE INTEGER ' automaton to use several keys
VAR DXY(8,2) TYPE INTEGER ' automaton for moveForward
VAR key TYPE INTEGER
VAR range TYPE INTEGER
VAR player1Points TYPE INTEGER
VAR player2Points TYPE INTEGER
VAR Clock,Clock0 TYPE INTEGER
VAR Period TYPE INTEGER = 8

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 Process1
LET player1LIN0 = player1LIN
LET player1COL0 = player1COL
LET DirectionP1 = DirectionP1 + KeyMap(key,1,1)
IF DirectionP1 > 8 THEN LET DirectionP1 = 1
IF DirectionP1 < 1 THEN LET DirectionP1 = 8
LET player1LIN = player1LIN + DXY(DirectionP1,DY)
IF player1LIN > 21 THEN LET player1LIN = 1
IF player1LIN < 1 THEN LET player1LIN = 21
LET player1COL = player1COL + DXY(DirectionP1,DX)
IF player1COL > 31 THEN LET player1COL = 1
IF player1COL < 1 THEN LET player1COL = 31
PRINT AT  player1LIN0 , player1COL0 ; " ";
PRINT AT  player1LIN , player1COL ;  ink 6; Sprite$(DirectionP1);
END PROCEDURE

PROCEDURE Process2
LET player2LIN0 = player2LIN
LET player2COL0 = player2COL
LET DirectionP2 = DirectionP2 + KeyMap(key,2,1)
IF DirectionP2 > 8 THEN LET DirectionP2 = 1
IF DirectionP2 < 1 THEN LET DirectionP2 = 8
LET player2LIN = player2LIN + DXY(DirectionP2,DY)
IF player2LIN > 21 THEN LET player2LIN = 0
IF player2LIN < 0 THEN LET player2LIN = 21
LET player2COL = player2COL + DXY(DirectionP2,DX)
IF player2COL > 31 THEN LET player2COL = 0
IF player2COL < 0 THEN LET player2COL = 31
PRINT AT  player2LIN0 , player2COL0 ; " ";
PRINT AT  player2LIN , player2COL ;  ink 5; Sprite$(DirectionP2);
END PROCEDURE

PROCEDURE Player1Shot
BORDER 2
LET player2Points = player2Points + 1
PRINT AT  23, 20; PAPER 1; ink 4; "Points: "; player2Points;
LET player1LIN0 = player1LIN
LET player1COL0 = player1COL
PRINT AT  player1LIN , player1COL ; "\F"
LET missile2Fuel = 0
PRINT AT  missile2LIN , missile2COL ;  ink 5; "\F"
LET player1LIN = player2LIN + 11
IF player1LIN > 21 THEN LET player1LIN = player1LIN - 21
LET player1COL = 0
LET DirectionP1 = 1
FOR i = 1 TO 20 : BEEP .005,5*RND : NEXT i
PRINT AT  player1LIN0 , player1COL0 ; " "
PRINT AT  player1LIN , player1COL ;  ink 6; Sprite$(DirectionP1)
PRINT AT  missile2LIN , missile2COL ; " "
END PROCEDURE

PROCEDURE Player2Shot
BORDER 2
LET player1Points = player1Points + 1
PRINT AT  23, 0; PAPER 1; ink 4; "Points: "; player1Points;
LET player2LIN0 = player2LIN
LET player2COL0 = player2COL
PRINT AT  player2LIN , player2COL ; "\F"
LET missile1Fuel = 0
PRINT AT  missile1LIN , missile1COL ;  ink 6; "\F"
LET player2LIN = player1LIN + 11
IF player2LIN > 21 THEN LET player2LIN = player2LIN - 21
LET player2COL = 31
LET DirectionP2 = 5
FOR i = 1 TO 20 : BEEP .005,5*RND : NEXT i
PRINT AT  player2LIN0 , player2COL0 ; " "
PRINT AT  player2LIN , player2COL ;  ink 5; Sprite$(DirectionP2)
PRINT AT  missile1LIN , missile1COL ; " "
END PROCEDURE

PROCEDURE ProcessMissile1
LET missile1LIN0 = missile1LIN
LET missile1COL0 = missile1COL
LET missile1LIN = missile1LIN + DXY(DirectionM1,DY)
IF missile1LIN > 21 THEN LET missile1LIN = 1
IF missile1LIN < 1 THEN LET missile1LIN = 21
LET missile1COL = missile1COL + DXY(DirectionM1,DX)
IF missile1COL > 31 THEN LET missile1COL = 1
IF missile1COL < 1 THEN LET missile1COL = 31
LET missile1Fuel = missile1Fuel - 1
PRINT AT  missile1LIN0 , missile1COL0 ; " "
IF ABS(missile1LIN - player2LIN) <= range AND ABS(missile1COL - player2COL) <= range THEN Player2Shot
IF missile1Fuel > 0 THEN PRINT AT  missile1LIN , missile1COL ;  ink 6; "\A"
END PROCEDURE

PROCEDURE ProcessMissile2
LET missile2LIN0 = missile2LIN
LET missile2COL0 = missile2COL
LET missile2LIN = missile2LIN + DXY(DirectionM2,DY)
IF missile2LIN > 21 THEN LET missile2LIN = 1
IF missile2LIN < 1 THEN LET missile2LIN = 21
LET missile2COL = missile2COL + DXY(DirectionM2,DX)
IF missile2COL > 31 THEN LET missile2COL = 1
IF missile2COL < 1 THEN LET missile2COL = 31
LET missile2Fuel = missile2Fuel - 1
PRINT AT  missile2LIN0 , missile2COL0 ; " "
IF ABS(missile2LIN - player1LIN) <= range AND ABS(missile2COL - player1COL) <= range THEN Player1Shot
IF missile2Fuel > 0 THEN PRINT AT  missile2LIN , missile2COL ;  ink 5; "\A"
END PROCEDURE

PROCEDURE Fire1
LET missile1Fuel = 15
LET DirectionM1 = DirectionP1
LET missile1COL = player1COL + DXY(DirectionP1,DX)
IF missile1COL > 31 THEN LET missile1COL = 1
IF missile1COL < 1 THEN LET missile1COL = 31
LET missile1LIN = player1LIN + DXY(DirectionP1,DY)
IF missile1LIN > 21 THEN LET missile1LIN = 1
IF missile1LIN < 1 THEN LET missile1LIN = 21
PRINT AT  missile1LIN , missile1COL ;  ink 6; "\A"
END PROCEDURE

PROCEDURE Fire2
LET missile2Fuel = 15
LET DirectionM2 = DirectionP2
LET missile2COL = player2COL + DXY(DirectionP2,DX)
IF missile2COL > 31 THEN LET missile2COL = 1
IF missile2COL < 1 THEN LET missile2COL = 31
LET missile2LIN = player2LIN + DXY(DirectionP2,DY)
IF missile2LIN > 21 THEN LET missile2LIN = 1
IF missile2LIN < 1 THEN LET missile2LIN = 21
PRINT AT  missile2LIN , missile2COL ;  ink 5; "\A"
END PROCEDURE

PROCEDURE WaitForPlayer
VAR B$ TYPE STRING
PRINT AT 13,3; ink 6; "  Difficulty: 1, 2 or 3"
REPEAT
  PAUSE 0
  LET B$ = INKEY$
UNTIL B$ >= "1" AND B$ <= "3"
LET range = 3 - VAL B$
LET dif = VAL B$
IF dif = 1 THEN Period = 24
IF dif = 2 THEN Period = 16
IF dif = 3 THEN Period = 8
RANDOMIZE
LET Clock0 = PEEK 23672
CLS
END PROCEDURE

PROCEDURE InitGame
LET player1LIN = 5 : LET player1COL = 0 : LET DirectionP1 = 1
LET player2LIN = 16 : LET player2COL = 31 : LET DirectionP2 = 5
PRINT AT player1LIN, player1COL; ink 6; Sprite$(DirectionP1)
PRINT AT player2LIN, player2COL; ink 5; Sprite$(DirectionP2)
LET missile1Fuel = 0
LET missile2Fuel = 0
LET player1Points = 0
LET player2Points = 0
END PROCEDURE

PROCEDURE initScreen
BORDER 1 : PAPER 1 : ink 7 : CLS
PRINT AT  0,9; ink 4; "Dogfight David";
PRINT AT 21,0; ink 4; "    (c) 2022, 2023 STARSOFT";
PRINT AT 22,0; ink 4; "       Pascalated BASIC";
PRINT AT 23,0; ink 4; "  Compiled by Boriel ZX BASIC";
PRINT AT 10,3; "Player1: ASD  Player2: JKL"
PRINT AT 13,9; ink 6; "Please wait..."
END PROCEDURE

PROCEDURE DefineChars
VAR n TYPE INTEGER
'RESTORE Sprites
READ car$
REPEAT
  FOR i=0 TO 7
    READ n
    POKE USR car$+i,n
  NEXT i
  READ car$
UNTIL car$ = ""
END PROCEDURE

PROCEDURE Sprites
DATA "A"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00001000
DATA BIN 00011100
DATA BIN 00111110
DATA BIN 00011100
DATA BIN 00001000
DATA BIN 00000000
DATA "B"
DATA BIN 00000010
DATA BIN 01000011
DATA BIN 01100110
DATA BIN 01111100
DATA BIN 00111000
DATA BIN 00011100
DATA BIN 00101110
DATA BIN 00000111
DATA "C"
DATA BIN 00111100
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 11111111
DATA BIN 01111110
DATA BIN 00011000
DATA BIN 00000000
DATA "D"
DATA BIN 01000000
DATA BIN 11000010
DATA BIN 01100110
DATA BIN 00111110
DATA BIN 00011100
DATA BIN 00111000
DATA BIN 01110100
DATA BIN 11100000
DATA "E"
DATA BIN 00010000
DATA BIN 00110000
DATA BIN 00110001
DATA BIN 01111111
DATA BIN 01111111
DATA BIN 00110001
DATA BIN 00110000
DATA BIN 00010000
DATA "F"
DATA BIN 00100010
DATA BIN 01010101
DATA BIN 10001000
DATA BIN 00000000
DATA BIN 01000100
DATA BIN 10101010
DATA BIN 00010001
DATA BIN 00000000
DATA "G"
DATA BIN 00001000
DATA BIN 00001100
DATA BIN 10001100
DATA BIN 11111110
DATA BIN 11111110
DATA BIN 10001100
DATA BIN 00001100
DATA BIN 00001000
DATA "H"
DATA BIN 00000000
DATA BIN 00001110
DATA BIN 01011100
DATA BIN 00111000
DATA BIN 01111000
DATA BIN 11101100
DATA BIN 11000111
DATA BIN 10000010
DATA "I"
DATA BIN 00000000
DATA BIN 00011000
DATA BIN 01111110
DATA BIN 11111111
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00011000
DATA BIN 00111100
DATA "J"
DATA BIN 11100000
DATA BIN 01110100
DATA BIN 00111000
DATA BIN 00011100
DATA BIN 00111110
DATA BIN 01100110
DATA BIN 11000010
DATA BIN 01000000
DATA ""
END PROCEDURE

PROCEDURE InitProg
DefineChars
REM automaton for plane image
'DIM Sprite$(8)
LET Sprite$(1) = "\G"
LET Sprite$(2) = "\J"
LET Sprite$(3) = "\I"
LET Sprite$(4) = "\H"
LET Sprite$(5) = "\E"
LET Sprite$(6) = "\B"
LET Sprite$(7) = "\C"
LET Sprite$(8) = "\D"
REM automaton for moveForward
'DIM DXY(8,2)
LET DXY(1,DX) = 1 : LET DXY(1,DY) = 0
LET DXY(2,DX) = 1 : LET DXY(2,DY) = -1
LET DXY(3,DX) = 0 : LET DXY(3,DY) = -1
LET DXY(4,DX) = -1 : LET DXY(4,DY) = -1
LET DXY(5,DX) = -1 : LET DXY(5,DY) = 0
LET DXY(6,DX) = -1 : LET DXY(6,DY) = 1
LET DXY(7,DX) = 0 : LET DXY(7,DY) = 1
LET DXY(8,DX) = 1 : LET DXY(8,DY) = 1
REM automaton for keys
'DIM KeyMap(32,2,2)
LET KeyMap(2,1,1) = 1
LET KeyMap(3,1,2) = TRUE
LET KeyMap(5,1,1) = -1
LET KeyMap(4,1,1) = -1 : LET KeyMap(4,1,2) = TRUE
LET KeyMap(7,1,1) = 1 : LET KeyMap(7,1,2) = TRUE
LET KeyMap(9,2,1) = 1
LET KeyMap(5,2,2) = TRUE
LET KeyMap(3,2,1) = -1
LET KeyMap(13,2,1) = -1 : LET KeyMap(4,2,2) = TRUE
LET KeyMap(7,2,1) = 1 : LET KeyMap(7,2,2) = TRUE
END PROCEDURE

PROCEDURE Game
InitProg
initScreen
InitGame
WaitForPlayer
PRINT AT 23,0; ink 4; "Points: "; player1Points;
PRINT AT 23,20; ink 4; "Points: "; player2Points;
REPEAT
  WaitClock
  BORDER 1
  LET key = 192 - IN 65022
  Process1
  IF missile1Fuel = 0 THEN IF KeyMap(key,1,2) = 1 THEN BEEP .1,5: Fire1
  IF missile1Fuel THEN ProcessMissile1
  IF missile2Fuel THEN ProcessMissile2
  LET key = 192 - IN 49150
  Process2
  IF missile2Fuel = 0 THEN IF KeyMap(key,2,2) = 1 THEN BEEP .1,5: Fire2
  IF missile1Fuel THEN ProcessMissile1
  IF missile2Fuel THEN ProcessMissile2
UNTIL FALSE
END PROCEDURE

BEGIN
REM PRINT "Demo for Pascalated BASIC"
PAUSE 50
Game
END
Print this item

  Pascalated ZX BASIC Demo #11 - The Towers of Hanoi
Posted by: zarsoft - 04-09-2023, 01:01 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE


Code:
' PROGRAM The Towers of Hanoi
' (c) Zarsoft 2022 Pascalated BASIC
' (c) Zarsoft 2023 Pascalated Boriel ZX BASIC
' 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 Towers of Hanoi

' CONSTant declarations
CONST black TYPE INTEGER = 0
CONST blue TYPE INTEGER = 1
CONST green TYPE INTEGER = 4
CONST white TYPE INTEGER = 7
CONST MinDisks TYPE INTEGER = 6
CONST PoleLine TYPE INTEGER = 16

' VAR - Global variables
VAR DiskShape(11) TYPE STRING ' :REM disk ARRAY (0..10) OF ARRAY (1..19) OF CHAR;
VAR Pole(3,11) TYPE INTEGER ' pole ARRAY (1..03) OF ARRAY (1..10) OF INTEGER;
VAR PoleLen(3) TYPE INTEGER :REM REM PoleLen :ARRAY (1..03) OF INTEGER;
VAR PoleCol(3) TYPE INTEGER :REM REM PoleCol :ARRAY (1..03) OF INTEGER;
VAR f,t TYPE INTEGER ' from, to
VAR MaxDisks TYPE INTEGER
VAR movement TYPE INTEGER
VAR LegalMove TYPE BOOLEAN
VAR abort TYPE BOOLEAN
VAR TheEnd TYPE BOOLEAN

PROCEDURE CheckEnd
LET TheEnd = TRUE
IF abort THEN LET TheEnd = FALSE
IF (MaxDisks < MinDisks)
  LET TheEnd = FALSE
  PRINT AT PoleLine+2,0;
  PRINT INK 3;"    =-- NOT ENOUGH DISKS --="
  PRINT INK 2;"           Try again  "
ELSEIF (MaxDisks >= MinDisks) AND (movement > 2^MaxDisks-1)
  LET TheEnd = FALSE
  PRINT AT PoleLine+2,0;
  PRINT INK 3;"  =-- TOO MUCH MOVEMENTS --="
  PRINT INK 2;"         Try again  "
  PAUSE 10
ENDIF
PRINT AT 21,0;PAPER 1;"   Press any key to continue    "
PAUSE 10
PAUSE 10
PAUSE 0
END PROCEDURE

PROCEDURE finalization
PRINT AT PoleLine+2,0;
PRINT INK 3;"  ===-- CONGRATULATIONS! --==="
PRINT INK 2;"                                "
: FOR i=-11 TO 11: BEEP .01,i: BEEP .01,ABS(i): NEXT i
PAUSE 0
END PROCEDURE

PROCEDURE MoveDisk (f TYPE INTEGER,t TYPE INTEGER)
VAR column TYPE INTEGER
VAR l,col TYPE INTEGER
BEGIN
LET movement = movement+1
PRINT AT 2,0;"This move: ";movement
LET PoleLen(t) = PoleLen(t)+1
LET Pole(t,PoleLen(t)) = Pole(f,PoleLen(f))
LET Pole(f,PoleLen(f)) = 0
LET PoleLen(f) = PoleLen(f)-1
REM move up
LET col = PoleCol(f)
FOR l = PoleLine-PoleLen(f)-2 TO PoleLine-11 STEP -1
  PRINT AT l,col;INK green;DiskShape$(Pole(t,PoleLen(t))+1);
  PRINT AT l+1,col;INK blue;DiskShape$(0+1);
NEXT l
REM left/right
IF f < t
  REM move right
  LET col = PoleCol(f)+2
  WHILE col < PoleCol(t)
    PRINT AT PoleLine-11,col-2;INK green;"  ";DiskShape$(Pole(t,PoleLen(t))+1);
    LET col = col+2
  END WHILE
ELSE
  REM move left
  LET col = PoleCol(f)-2
  WHILE col > PoleCol(t)
    PRINT AT PoleLine-11,col;INK green;DiskShape$(Pole(t,PoleLen(t))+1);"  ";
    LET col = col-2
  END WHILE
ENDIF
PRINT AT PoleLine-11,PoleCol(t);"         ";
PRINT AT PoleLine-11,0;"                                ";
PRINT AT PoleLine-10,PoleCol(t);INK green;DiskShape$(Pole(t,PoleLen(t))+1);
REM move down
LET col = PoleCol(t)
FOR l = PoleLine-9 TO PoleLine-PoleLen(t)
  PRINT AT l,col;INK green;DiskShape$(Pole(t,PoleLen(t))+1);
  PRINT AT l-1,col;INK blue;DiskShape$(0+1);
NEXT l
END PROCEDURE

PROCEDURE CheckLegalMove
REM (VAR f,t:INTEGER);
LET LegalMove = TRUE
IF (f = t) OR (PoleLen(f) = 0)
  LET LegalMove = FALSE
ELSEIF PoleLen(t) <> 0
  IF NOT( Pole(f,PoleLen(f)) < Pole(t,PoleLen(t)) ) THEN LET LegalMove = FALSE
ENDIF
END PROCEDURE

PROCEDURE InputMove
REM (VAR f,t:INTEGER);
VAR k$ TYPE STRING
BEGIN
PRINT AT PoleLine+2,1;"MOVE FROM... ";
REPEAT
  PAUSE 0
  LET k$ = INKEY$
UNTIL k$ >= "0" AND k$ <= "9"
BEEP .1,5
LET f = VAL (k$)
LET k$ = "X"
IF f=0 THEN LET abort = TRUE: LET k$="0"
PRINT AT PoleLine+2,1;"MOVE FROM ";f;" TO... ";
WHILE NOT(abort) AND NOT (k$ >= "0" AND k$ <= "9")
  PAUSE 0
  LET k$ = INKEY$
END WHILE
BEEP .1,5
LET t = VAL k$
IF t=0 THEN LET abort = TRUE
IF abort THEN LET f = 1: LET t = 1
PRINT AT PoleLine+2,1;"                            ";
END PROCEDURE

PROCEDURE PrintPole (PoleNumber TYPE INTEGER)
VAR col TYPE INTEGER
VAR i TYPE INTEGER
BEGIN
LET col = PoleCol(PoleNumber)
FOR i = 1 TO 10
  IF Pole(PoleNumber,i) = 0 THEN INK blue
  IF Pole(PoleNumber,i) <> 0 THEN INK green
  PRINT AT PoleLine-i,col;DiskShape$(Pole(PoleNumber,i)+1);
NEXT i
INK white
END PROCEDURE

PROCEDURE Initialization
VAR i TYPE INTEGER
BEGIN
LET TheEnd = FALSE
LET abort = FALSE
LET PoleCol(1) = 1
LET PoleCol(2) = 1+9+2
LET PoleCol(3) = 1+9+2+9+2
LET DiskShape$( 1) =  "    |    "
LET DiskShape$( 2) =  "    1    "
LET DiskShape$( 3) =  "   \A2\C   "
LET DiskShape$( 4) =  "   \B3\B   "
LET DiskShape$( 5) =  "  \A\B4\B\C  "
LET DiskShape$( 6) =  "  \B\B5\B\B  "
LET DiskShape$( 7) =  " \A\B\B6\B\B\C "
LET DiskShape$( 8) =  " \B\B\B7\B\B\B "
LET DiskShape$( 9) =  "\A\B\B\B8\B\B\B\C"
LET DiskShape$(10) =  "\B\B\B\B9\B\B\B\B"
FOR i = 1 TO 10
  LET Pole(1,i) = 0
  LET Pole(2,i) = 0
  LET Pole(3,i) = 0
NEXT i
FOR i = 1 TO MaxDisks
  LET Pole(1,i) = MaxDisks-(i-1)
NEXT i
LET PoleLen(1) = MaxDisks
LET PoleLen(2) = 0
LET PoleLen(3) = 0
INK blue
PRINT AT PoleLine,PoleCol(1);
PRINT "\::\::\::\::1\::\::\::\::";
PRINT "  ";
PRINT "\::\::\::\::2\::\::\::\::";
PRINT "  ";
PRINT "\::\::\::\::3\::\::\::\::";
INK white
LET movement = 0
PRINT AT 0,7;INK green;"THE TOWERS OF HANOI"
PRINT AT 2,19;"Minimum: ";2^MaxDisks-1
PAPER blue: INK green
PRINT AT 21,0;"1,2,3 - Select pole    0 - ABORT"
PAPER black
END PROCEDURE

PROCEDURE AskMaxDisks
VAR  k$ TYPE CHAR
BEGIN
INK green
PRINT AT PoleLine+3,0;"NUMBER OF DISKS = [1..9] ";
REPEAT
  PAUSE 0
  LET k$ = INKEY$
UNTIL k$ >= "1" AND k$ <= "9"
BEEP .1,5
LET MaxDisks = VAL (k$)
IF MaxDisks=0 THEN LET MaxDisks = 10
PRINT AT PoleLine+2,1;
END PROCEDURE

PROCEDURE Introduction
REM VAR s :BOOLEAN
BEGIN
BORDER black: PAPER black:  INK green: CLS
PRINT "     THE TOWERS OF HANOI"
PRINT
INK white
PRINT "In the great temple of Brahma","in Benares of India, there is ","a plate with 3 diamond needles","under the dome that marks the","center of the world."
PRINT
PRINT "At the creation, God placed 64","disks of pure gold in the order of their sizes, from largest to smallest."
PRINT
PRINT "This is the Tower of Brahma."
PRINT
PRINT "Day and night unceasingly the","monks of the temple move the","disks from one diamond needle","to another."
PRINT
PRINT AT 21,0;PAPER 1;"Press any key to read the rules"
PAUSE 0
INK 6
CLS
PRINT INK 3;"RULES:"
PRINT
PRINT " 1 - Only one disk can be moved at a time."
PRINT
PRINT " 2 - A disk can only be placed","on a larger disk (or no smaller disk below)."
PRINT
PRINT " 3 - All disks must go to the","third needle."
PRINT
INK 7
PRINT "When all disks are moved from","the first needle to the third","needle forming the Tower of","Brahma, then will come the end","of the universe and all will","turn to dust."
PRINT
END PROCEDURE

PROCEDURE DefineChars
VAR n TYPE INTEGER
'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 00000000
DATA BIN 00000000
DATA BIN 00001111
DATA BIN 00001111
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "B"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "C"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 11110000
DATA BIN 11110000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA ""
END PROCEDURE

PROCEDURE MainRoutine
DefineChars
REPEAT
  Introduction
  AskMaxDisks
  CLS
  Initialization
  PrintPole(1)
  PrintPole(2)
  PrintPole(3)
  REPEAT
    InputMove: REM (f,t)
    CheckLegalMove: REM (f,t)
    IF LegalMove THEN MoveDisk(f,t)
  UNTIL (PoleLen(3) = MaxDisks) OR abort
  CheckEnd
UNTIL TheEnd
finalization
END PROCEDURE

BEGIN
CLS
PRINT "Demo for Pascalated BASIC"
MainRoutine
END
Print this item

  ZX Spectrum with Pascal interpreter instead of BASIC interpreter
Posted by: zarsoft - 04-01-2023, 08:48 AM - Forum: Gallery - No Replies

Now we can program the ZX Spectrum directly in Pascal language instead of BASIC language.

See the listing below:

[Image: w3.png]

To run an example online, click HERE.

After the program finishes, you can examine the Pascal listing with LIST and run the program again with RUN.

Print this item

  Microsoft Windows On The ZX Spectrum
Posted by: zarsoft - 04-01-2023, 08:25 AM - Forum: Gallery - Replies (2)

[Image: w1.png]

Microsoft Windows is out for the ZX Spectrum. It uses maximum memory (128K) and several diskettes (FDD) but we managed to get a demo version for the 48K. This demo version has some problems due to low memory but you can see what the 128K version looks like.
The box with 5 diskettes and manuals costs USD $34,99.

To run online - the demo version - click HERE.

[Image: w2.png]

Print this item