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

Username
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 294
» Latest member: nemo2k
» Forum threads: 1,027
» Forum posts: 6,211

Full Statistics

Online Users
There are currently 458 online users.
» 0 Member(s) | 455 Guest(s)
Bing, Google, Yandex

Latest Threads
My computer is haunted!
Forum: Bug Reports
Last Post: zarsoft
Today, 10:30 AM
» Replies: 0
» Views: 6
Includes in ASM
Forum: How-To & Tutorials
Last Post: bracckets
04-04-2024, 12:17 AM
» Replies: 2
» Views: 981
Store array information i...
Forum: Help & Support
Last Post: rbiondi
03-10-2024, 09:42 PM
» Replies: 0
» Views: 648
ScrollLeft function scrol...
Forum: Bug Reports
Last Post: rbiondi
03-07-2024, 03:57 PM
» Replies: 2
» Views: 1,267
string.bas errors when co...
Forum: Bug Reports
Last Post: rbiondi
03-01-2024, 10:10 AM
» Replies: 2
» Views: 1,114
Using Beepola with ZX BAS...
Forum: How-To & Tutorials
Last Post: edtoo
02-29-2024, 09:47 AM
» Replies: 15
» Views: 35,028
Johnny Bravo
Forum: Gallery
Last Post: zarsoft
02-11-2024, 11:20 PM
» Replies: 0
» Views: 662
Compiling +D G+DOS progra...
Forum: ZX Basic Compiler
Last Post: boriel
01-22-2024, 08:32 AM
» Replies: 4
» Views: 9,360
VAL = ? (solved)
Forum: Bug Reports
Last Post: zarsoft
01-03-2024, 11:44 PM
» Replies: 8
» Views: 4,446
Wrong math (solved)
Forum: Bug Reports
Last Post: zarsoft
01-03-2024, 11:38 PM
» Replies: 4
» Views: 2,440

 
  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

  Pascalated ZX BASIC Demo #10 - Worm
Posted by: zarsoft - 03-25-2023, 08:12 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE

Code:
' PROGRAM Worm
' (c) Starsoft 2020 Java console
' (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 Worm

' CONSTant declarations
CONST Period TYPE INTEGER = 8

' VAR - Global variables
VAR Clock,Clock0 TYPE INTEGER
VAR GAMEOVER TYPE BOOLEAN
VAR LIN, COL TYPE INTEGER
VAR Direction, DirectionOld TYPE INTEGER
VAR LengthMax TYPE INTEGER
VAR LengthCurrent TYPE INTEGER
VAR TailL, TailC TYPE INTEGER
VAR Cook TYPE INTEGER
VAR DirectionTail TYPE INTEGER
VAR Trail$(8,8) TYPE STRING ' automaton for PrintTrail
VAR TailDirection$(8,128) TYPE STRING ' automaton for getDirectionTail
VAR TailColor(150) TYPE INTEGER ' automaton for tail colors
VAR KeyMap$(128) TYPE STRING ' automaton to use several keys
VAR DX, DY TYPE INTEGER ' index for automaton for moveForward
VAR DXY(8,2) TYPE INTEGER ' automaton for moveForward
VAR Record TYPE INTEGER ' max length achieved

'--- KEYBOARD BUFFER ---

VAR BUFFER$ TYPE STRING = ""

PROCEDURE ScanKey
VAR key$ TYPE STRING = INKEY$
VAR l TYPE INTEGER
IF key$ <> "" THEN
  IF BUFFER$ = "" THEN
    LET BUFFER$ = BUFFER$+INKEY$
  ELSE
    LET l = LEN BUFFER$
    IF BUFFER$(l-1) <> key$ THEN LET BUFFER$ = BUFFER$+INKEY$
  ENDIF
ENDIF
END PROCEDURE

FUNCTION GetKey$ TYPE STRING
VAR result$ TYPE STRING
VAR l TYPE INTEGER
LET l = LEN BUFFER$
IF l = 0
  LET result$ = CHR 0
ELSEIF l = 1
  LET result$ = BUFFER$
  BUFFER$ = ""
ELSE
  LET result$ = BUFFER$(0)
  BUFFER$ = BUFFER$( 1 TO )
ENDIF
RETURN result$
END FUNCTION

'------------------------

PROCEDURE TheEnd
PRINT AT 21,10; ink 2; " GAME OVER "
BEEP .5,15: BEEP .5,10: BEEP .5,5: BEEP .5,0
PAUSE 50
IF LengthCurrent > Record
  PRINT AT 0,8; ink 2; " NEW HIGH SCORE "
  BEEP .5,10: BEEP .5,0: BEEP .5,20
  LET Record = LengthCurrent
ENDIF
REPEAT
UNTIL  INKEY$ = ""
FOR i=1 TO 5
  PAUSE 50
NEXT i
END PROCEDURE

PROCEDURE GiveFood
VAR cMin TYPE INTEGER = 3
VAR cMax TYPE INTEGER = 30
VAR lMin TYPE INTEGER = 3
VAR lMax TYPE INTEGER = 20
VAR l,c TYPE INTEGER
VAR food TYPE INTEGER
IF Cook < 10
  LET Cook = Cook+1
ELSE
  LET Cook = 0
  LET l = lMin + INT(RND * ((lMax - lMin) + 1))
  LET c = cMin + INT(RND * ((cMax - cMin) + 1))
  LET food = 1 + INT(RND * ((9 - 1) + 1))
  IF SCREEN$(l,c) = " " THEN PRINT AT l, c; food
ENDIF
END PROCEDURE

PROCEDURE PrintTrailOldVersion
IF DirectionOld = 5 AND Direction = 5
  LET r$ = "-"
ELSEIF DirectionOld = 5 AND Direction = 6
  LET r$ = "/"
ELSEIF DirectionOld = 5 AND Direction = 7
  LET r$ = "\\"
ELSEIF DirectionOld = 6 AND Direction = 6
  LET r$ = "|"
ELSEIF DirectionOld = 6 AND Direction = 5
  LET r$ = "/"
ELSEIF DirectionOld = 6 AND Direction = 8
  LET r$ = "\\"
ELSEIF DirectionOld = 7 AND Direction = 7
  LET r$ = "|"
ELSEIF DirectionOld = 7 AND Direction = 5
  LET r$ = "\\"
ELSEIF DirectionOld = 7 AND Direction = 8
  LET r$ = "/"
ELSEIF DirectionOld = 8 AND Direction = 8
  LET r$ = "-"
ELSEIF DirectionOld = 8 AND Direction = 6
  LET r$ = "\\"
ELSEIF DirectionOld = 8 AND Direction = 7
  LET r$ = "/"
ELSE
  LET r$ = "."
ENDIF
PRINT AT LIN, COL; r$
END PROCEDURE

PROCEDURE PrintTrail
PRINT AT LIN, COL; ink TailColor(CODE Trail$(DirectionOld,Direction)); Trail$(DirectionOld,Direction)
END PROCEDURE

PROCEDURE getDirectionTailOld1Version
LET c$ = SCREEN$(TailL,TailC)
IF DirectionTail = 5 AND c$ = "-"
  LET DirectionTail = 5
ELSEIF DirectionTail = 5 AND c$ = "/"
  LET DirectionTail = 6
ELSEIF DirectionTail = 5 AND c$ = "\\"
  LET DirectionTail = 7
ELSEIF DirectionTail = 6 AND c$ = "|"
  LET DirectionTail = 6
ELSEIF DirectionTail = 6 AND c$ = "/"
  LET DirectionTail = 5
ELSEIF DirectionTail = 6 AND c$ = "\\"
  LET DirectionTail = 8
ELSEIF DirectionTail = 7 AND c$ = "|"
  LET DirectionTail = 7
ELSEIF DirectionTail = 7 AND c$ = "/"
  LET DirectionTail = 8
ELSEIF DirectionTail = 7 AND c$ = "\\"
  LET DirectionTail = 5
ELSEIF DirectionTail = 8 AND c$ = "-"
  LET DirectionTail = 8
ELSEIF DirectionTail = 8 AND c$ = "/"
  LET DirectionTail = 7
ELSEIF DirectionTail = 8 AND c$ = "\\"
  LET DirectionTail = 6
ENDIF
END PROCEDURE

PROCEDURE getDirectionTailOld2Version
LET c$ = SCREEN$(TailL,TailC)
LET DirectionTail = VAL TailDirection$(DirectionTail,CODE c$)
END PROCEDURE

PROCEDURE getDirectionTail
VAR c TYPE INTEGER
LET c = ATTR(TailL,TailC) - 56
LET DirectionTail = VAL TailDirection$(DirectionTail, c)
END PROCEDURE

PROCEDURE MoveForwardOldVersion
PrintTrail
REM move worm
IF Direction = 8
  LET COL = COL+1
ELSEIF Direction = 5
  LET COL = COL-1
ELSEIF Direction = 7
  LET LIN = LIN-1
ELSE
  LET LIN = LIN+1
ENDIF
LET c$ = SCREEN$(LIN,COL)
IF c$ = " "
  REM nothing ahead
  PRINT AT  LIN, COL; "o"  : REM head of worm
  PRINT AT 22, 8; LengthCurrent
ELSEIF c$ >= "1" AND c$ <= "9"
  REM steped on food
  LET LengthMax = LengthMax + VAL c$
  PRINT AT  LIN, COL; "o";
  BEEP .005,INT (30*RND)
ELSE
  PRINT AT  LIN, COL; "X"
  LET GAMEOVER = TRUE
ENDIF
LET DirectionOld = Direction
REM process Tail
IF LengthCurrent < LengthMax BEGIN w
  LET LengthCurrent = LengthCurrent+1
ELSE
  getDirectionTail
  PRINT AT TailL, TailC; " "
  IF DirectionTail = 6
    LET TailL = TailL+1
  ELSEIF DirectionTail = 5
    LET TailC = TailC-1
  ELSEIF DirectionTail = 8
    LET TailC = TailC+1
  ELSEIF DirectionTail = 7
    LET TailL = TailL-1
  ENDIF
ENDIF
END PROCEDURE

PROCEDURE MoveForward
PrintTrail
REM move worm
LET LIN = LIN + DXY(Direction,DY)
LET COL = COL + DXY(Direction,DX)
LET c$ = SCREEN$(LIN,COL)
IF c$ = " "
  REM nothing ahead
  PRINT AT  LIN, COL; "o"  : REM head of worm
  PRINT AT 22, 8; LengthCurrent
ELSEIF c$ >= "1" AND c$ <= "9"
  REM steped on food
  LET LengthMax = LengthMax + VAL c$
  PRINT AT  LIN, COL; "o";
  BEEP .01,INT (30*RND)
ELSE
  PRINT AT  LIN, COL; "X"
  LET GAMEOVER = TRUE
ENDIF
LET DirectionOld = Direction
REM process Tail
IF LengthCurrent < LengthMax
  LET LengthCurrent = LengthCurrent+1
ELSE
  getDirectionTail
  PRINT AT TailL, TailC; " "
  LET TailL = TailL + DXY(DirectionTail,DY)
  LET TailC = TailC + DXY(DirectionTail,DX)
ENDIF
END PROCEDURE

PROCEDURE WaitClock
VAR elapsed TYPE INTEGER
REPEAT
  ScanKey
  LET Clock = PEEK 23672
  LET elapsed = Clock-Clock0
  IF elapsed<0 THEN LET elapsed = elapsed+256
UNTIL elapsed >= Period
LET Clock0 = Clock0 + Period: IF Clock0 > 255 THEN LET Clock0 = Clock0 - 256
REM PRINT AT 0,0;INK 2;elapsed;"  ";
END PROCEDURE

PROCEDURE WaitForPlayer
PRINT AT 18,5;"Keys: 5678 QAOP arrows"
PRINT AT 19,3;"  PRESS ANY KEY TO START  "
FOR i = -20 TO 20: BEEP .005,ABS i: NEXT i
REPEAT
  PAUSE 0
  LET BUFFER$ = KeyMap$(CODE (INKEY$+" ") )
UNTIL BUFFER$ >= "5" AND BUFFER$ <= "8"
BEEP .1,20
LET Direction = VAL BUFFER$
LET DirectionOld = Direction
LET DirectionTail = Direction
LET Clock0 = PEEK 23672
PRINT AT 18,5;"                      "
PRINT AT 19,5;"                      "
END PROCEDURE

PROCEDURE InitGame
BORDER 7: PAPER 7: INK 0: CLS
REM horizontal frame
FOR i=0 TO 31
  REM  top frame
  PRINT AT  0, i; "#";
  REM  bottom frame
  PRINT AT  21, i; "#";
NEXT i
REM vertical frame
FOR i=0 TO 21
  REM  left frame
  PRINT AT  i, 0; "#";
  REM  right frame
  PRINT AT  i, 31; "#";
NEXT i
REM Titulos
PRINT AT  0, 13; ink 1; "WORM";
PRINT AT 22, 0; "Length: ";
PRINT AT 23, 0; "Record: "; Record
PRINT AT 22, 23; "(c) 2023";AT  23, 23; "STARSOFT";
LET LIN = 10 : LET COL = 10
LET TailL = 10 : LET TailC = 10
LET Direction = 0 : LET DirectionOld = 0 : REM must init with first move
LET Cook= 0
LET BUFFER$ = ""
PRINT AT LIN, COL; "o" : REM head of worm
LET LengthMax = 2 : LET LengthCurrent = 1
REM PRINT AT  1, 10; LengthCurrent
PRINT AT 22, 8; LengthCurrent
LET GAMEOVER = FALSE
END PROCEDURE

PROCEDURE Game
InitGame
WaitForPlayer
REPEAT
  WaitClock
  LET key$ = GetKey
  LET key$ = KeyMap$(CODE (key$+" ") )
  IF key$ >= "5" AND key$ <= "8" THEN  IF Direction + VAL key$ <> 13 THEN LET Direction = VAL key$
  MoveForward
  GiveFood
UNTIL GAMEOVER
TheEnd
END PROCEDURE

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

PROCEDURE DataChars
DATA "A"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 11111111
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "B"
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA "C"
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00011111
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "D"
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 11110000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA "E"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 11110000
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA "F"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00011111
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA BIN 00010000
DATA ""
END PROCEDURE

PROCEDURE InitProg
REM CLS: PRINT AT 18,5;"Please wait..."
LET Record = 0
DefineChars
REM automaton for PrintTrail
REM DIM Trail$(8,8)
LET Trail$(5,5) = "\A" : REM "-"
LET Trail$(5,6) = "\F" : REM "/"
LET Trail$(5,7) = "\C" : REM "\\"
LET Trail$(6,6) = "\B" : REM "|"
LET Trail$(6,5) = "\D" : REM "/"
LET Trail$(6,8) = "\C" : REM "\\"
LET Trail$(7,7) = "\B" : REM "|"
LET Trail$(7,5) = "\E" : REM "\\"
LET Trail$(7,8) = "\F" : REM "/"
LET Trail$(8,8) = "\A" : REM "-"
LET Trail$(8,6) = "\E" : REM "\\"
LET Trail$(8,7) = "\D" : REM "/"
REM automaton for getDirectionTail
REM DIM TailDirection$(8,4)
LET TailDirection$(5,1) = "5"
LET TailDirection$(5,3) = "7"
LET TailDirection$(5,4) = "6"
LET TailDirection$(6,2) = "6"
LET TailDirection$(6,3) = "8"
LET TailDirection$(6,4) = "5"
LET TailDirection$(7,2) = "7"
LET TailDirection$(7,3) = "5"
LET TailDirection$(7,4) = "8"
LET TailDirection$(8,1) = "8"
LET TailDirection$(8,3) = "6"
LET TailDirection$(8,4) = "7"
REM automaton for moveForward
REM DIM DXY(8,2)
LET DX = 1 : LET DY = 2
LET DXY(5,DX) = -1 : LET DXY(5,DY) = 0
LET DXY(6,DX) = 0 : LET DXY(6,DY) = 1
LET DXY(7,DX) = 0 : LET DXY(7,DY) = -1
LET DXY(8,DX) = 1 : LET DXY(8,DY) = 0
REM automaton for tail colors
REM DIM TailColor(150)
LET TailColor(CODE("\A")) = 1
LET TailColor(CODE("\B")) = 2
LET TailColor(CODE("\C")) = 3
LET TailColor(CODE("\D")) = 4
LET TailColor(CODE("\E")) = 3
LET TailColor(CODE("\F")) = 4
REM Table for accept 5678 qaop and arrows
REM DIM KeyMap$(128)
REM left
LET KeyMap$(CODE "5") = "5"
LET KeyMap$(CODE "o") = "5"
LET KeyMap$(CODE "O") = "5"
LET KeyMap$(8) = "5" : REM arrow
REM right
LET KeyMap$(CODE "8") = "8"
LET KeyMap$(CODE "p") = "8"
LET KeyMap$(CODE "P") = "8"
LET KeyMap$(9) = "8" : REM arrow
REM up
LET KeyMap$(CODE "7") = "7"
LET KeyMap$(CODE "q") = "7"
LET KeyMap$(CODE "Q") = "7"
LET KeyMap$(11) = "7" : REM arrow
REM down
LET KeyMap$(CODE "6") = "6"
LET KeyMap$(CODE "a") = "6"
LET KeyMap$(CODE "A") = "6"
LET KeyMap$(10) = "6" : REM arrow
END PROCEDURE

PROCEDURE MainRoutine
InitProg
REPEAT
  Game
UNTIL FALSE
END PROCEDURE

BEGIN
POKE 23739,244: REM restore messages
PRINT PAPER 5;INK 0;AT 1,13;"   Do you think   ";AT 2,13;"there will be life";AT 3,13;" in other apples?";
FOR j = 1 TO 3
  FOR i = 0 TO 20: BEEP .005,i: NEXT i
NEXT j
PAUSE 2*50
MainRoutine
END

Print this item

  Pascalated ZX BASIC Demo #9 - 15
Posted by: zarsoft - 03-19-2023, 11:01 AM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE

Code:
' PROGRAM 15
' (c) 2023 by Zarsoft
' Written by Ze Oliveira
' Demo for the Pascalated language
' Pascalated Sinclair BASIC (c) 1987 by ZarSoft
' Pascalated BASIC Converter (c) 2021 by Zarsoft
' Pascalated Boriel (c) 2023 by ZarSoft
' ZX BASIC Compiler (c) 2008 by Boriel

#include <input.bas>  ' number = VAL INPUTable(12)
#include <screen.bas> ' SCREEN$ function
#include <attr.bas>   ' ATTR function

'--- Pascalated Boriel ---
'#define CONST     CONST
#define VAR       DIM
#define INTEGER   LONG
#define REAL      FLOAT
#define CHAR      STRING
'#define STRING    STRING
#define BOOLEAN   UBYTE
#define TYPE      AS
'#define WHILE    WHILE
#define REPEAT    DO
#define UNTIL     LOOP UNTIL
#define PROCEDURE SUB
#define PROGRAM   REM
CONST   TRUE      TYPE BOOLEAN = 1
CONST   FALSE     TYPE BOOLEAN = 0

' CONSTant declarations

' VAR - Global variables
REM VAR B$(4,4) TYPE CHAR '--- the board
VAR Board$(4) TYPE STRING '--- the board
VAR Table(127,2) TYPE INTEGER '--- table for key conversion onto movements Lin,Col
VAR Success TYPE BOOLEAN '--- board completed
VAR PositionL TYPE INTEGER '--- current position of the blank space
VAR PositionC TYPE INTEGER '--- current position of the blank space
VAR NewPositionL TYPE INTEGER
VAR NewPositionC TYPE INTEGER
VAR PosL TYPE INTEGER '--- position of the board
VAR PosC TYPE INTEGER '--- position of the board

PROCEDURE GameOver
PRINT AT 21,10;FLASH 1;"SUCCESS!";
PAUSE 50
PRINT AT 22,3;"GAME OVER - insert coin";
PAUSE 0
END PROCEDURE

PROCEDURE ShowPosition
PRINT AT PosL+0+3*PositionL,PosC+3*PositionC;"\:'\''\':";
PRINT AT PosL+1+3*PositionL,PosC+3*PositionC;"\: ";Board$(PositionL)(PositionC);"\ :";
PRINT AT PosL+2+3*PositionL,PosC+3*PositionC;"\:.\..\.:";
END PROCEDURE

PROCEDURE HidePosition
PRINT AT PosL+0+3*PositionL,PosC+3*PositionC;"\::\::\::";
PRINT AT PosL+1+3*PositionL,PosC+3*PositionC;"\::\::\::";
PRINT AT PosL+2+3*PositionL,PosC+3*PositionC;"\::\::\::";
END PROCEDURE

PROCEDURE MovePiece
LET Board$(PositionL)(PositionC) = Board$(NewPositionL)(NewPositionC)
LET Board$(NewPositionL)(NewPositionC) = " "
ShowPosition
LET PositionL = NewPositionL
LET PositionC = NewPositionC
HidePosition
IF Board$(4) = "MNO " THEN IF Board$(3) = "IJKL" THEN IF Board$(2) = "EFGH" THEN IF Board$(1) = "ABCD" THEN LET Success = TRUE
END PROCEDURE

FUNCTION ReadKey TYPE INTEGER
REPEAT
  PAUSE 0
  LET k$ = INKEY$
UNTIL k$ <> ""
REM PRINT AT 21,0;CODE k$;" ";
BEEP .01,10
RETURN CODE k$
END FUNCTION

PROCEDURE ShowBoard
VAR bakL TYPE INTEGER
VAR bakC TYPE INTEGER
BORDER 1 : PAPER 1 : INK 7 : CLS
PRINT AT 0,9;"--- ";INK 3;15;INK 7;" ---"
PRINT AT 2,5;INK 5;"Sort the characters"
PRINT AT 3,3;INK 5;"(in alphabetical order)"
PRINT AT 20,3;INK 5;"Keys: 5678 QAOP arrows";
PRINT AT 22,3;INK 0;"   Pascalated BASIC       ";
PRINT AT 23,3;INK 0;"Compiled by ZX BASIC (Boriel)";
PAPER 0 : INK 7
REM backup vars because there is no local vars
LET bakL = PositionL
LET bakC = PositionC
REM show all positions
FOR L=1 TO 4
  FOR C=1 TO 4
    LET PositionL = L
    LET PositionC = C
    ShowPosition
  NEXT C
NEXT L
REM restore vars
LET PositionL = bakL
LET PositionC = bakC
HidePosition
REM shadow on the bottom
FOR C=1 TO 12
  PRINT AT PosL+3+12,PosC+2+C;" ";
NEXT C
PRINT AT PosL+3+12,PosC+2+1;INK 1;"\. ";
PRINT AT PosL+3+12,PosC+3+12;" ";
REM shadow on the right
FOR L=1 TO 12
  PRINT AT PosL+2+L,PosC+3+12;" ";
NEXT L
PRINT AT PosL+2+1,PosC+3+12;INK 1;"\':";
END PROCEDURE

PROCEDURE InitVariables
LET PosL = 3
LET PosC = 5
REM Board
REM DIM Board$(4,4)
REM board for debug
LET Board$(1) = ".ABCD"
LET Board$(2) = ".EFGH"
LET Board$(3) = ".IJKL"
LET Board$(4) = ".MN O"
LET PositionL = 4
LET PositionC = 3
REM inverse order
LET Board$(1) = ". ONM"
LET Board$(2) = ".LKJI"
LET Board$(3) = ".HGFE"
LET Board$(4) = ".DCBA"
LET PositionL = 1
LET PositionC = 1
LET Success = FALSE
REM Table for keyboard conversion to make movements
REM DIM Table(128,2)
REM left
LET Table(CODE "5",2) = 1
LET Table(CODE "o",2) = 1
LET Table(CODE "O",2) = 1
LET Table(8,2) = 1 : REM arrow
REM right
LET Table(CODE "8",2) = -1
LET Table(CODE "p",2) = -1
LET Table(CODE "P",2) = -1
LET Table(9,2) = -1 : REM arrow
REM up
LET Table(CODE "7",1) = 1
LET Table(CODE "q",1) = 1
LET Table(CODE "Q",1) = 1
LET Table(11,1) = 1 : REM arrow
REM down
LET Table(CODE "6",1) = -1
LET Table(CODE "a",1) = -1
LET Table(CODE "A",1) = -1
LET Table(10,1) = -1 : REM arrow
END PROCEDURE

PROCEDURE MainRoutine
InitVariables
ShowBoard
REPEAT
  keycode = ReadKey
  IF Table(keycode,1)+Table(keycode,2) <> 0
    LET NewPositionL = PositionL+Table(keycode,1)
    LET NewPositionC = PositionC+Table(keycode,2)
    IF NewPositionL >=1 AND NewPositionL <= 4 AND NewPositionC >= 1 AND NewPositionC <= 4
      MovePiece
    ENDIF
  ENDIF
UNTIL Success
GameOver
END PROCEDURE

PROGRAM Game15
MainRoutine
' last 2 lines are going to be deleted
PRINT AT 23,0;
END PROGRAM

Print this item

  ARRAY of STRING (solved)
Posted by: zarsoft - 03-18-2023, 05:06 PM - Forum: Help & Support - Replies (2)

I'm a bit confused.

How do I do this?

DIM Board$(3,4)
LET Board$(1) = "ABCD"
LET Board$(2) = "EFGH"
LET Board$(3) = "IJKL"

Print this item

  Error: Invalid file name (solved)
Posted by: zarsoft - 03-17-2023, 08:22 PM - Forum: Bug Reports - Replies (2)

This code gives an error:
"F Invalid file name"

Code:
SUB SaveImage
DIM size AS LONG
size = 192*32+32*24
SAVE "image" CODE 16384,size
END SUB

SUB Run
SaveImage
END SUB

Run

Print this item

  Change RAMs on ZX Spectrum 128k
Posted by: Week of the agents - 03-15-2023, 07:42 PM - Forum: Help & Support - Replies (2)

Hi, Boriel

I'm taking part in the BASIC 2023 jam and plan to swap 128k RAM banks with graph data and use the shadow screen

Is there a way I can do it? ZX Basic use RAM0 for a stack and a data heap, can I somehow move them to a lower address WITH BASIC OPERATORS ONLY?

Print this item