Boriel Basic Forum

Welcome, Guest

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

Search Forums

(Advanced Search)

Forum Statistics

» Members: 277
» Latest member: Elemento26
» Forum threads: 1,087
» Forum posts: 6,490

Full Statistics

Online Users

There are currently 159 online users.
» 0 Member(s) | 157 Guest(s)
Bing, Google

Latest Threads

GuSprites
Forum: Help & Support
Last Post: zedex82
2026-06-19, 06:39 PM
» Replies: 2
» Views: 355

New video Couse / Nuevo c...
Forum: News
Last Post: Duefectu
2026-04-29, 11:02 PM
» Replies: 0
» Views: 2,694

location of heap manageme...
Forum: Help & Support
Last Post: boriel
2026-03-07, 12:13 AM
» Replies: 1
» Views: 744

non-paged supervisor code...
Forum: Help & Support
Last Post: sdo303
2026-02-20, 06:38 PM
» Replies: 8
» Views: 1,846

How to open fuse as an ex...
Forum: How-To & Tutorials
Last Post: Duefectu
2026-02-09, 01:52 PM
» Replies: 3
» Views: 1,742

Old zxbasic game errors
Forum: Help & Support
Last Post: boriel
2025-11-09, 11:52 AM
» Replies: 7
» Views: 2,537

Error: Undefined GLOBAL l...
Forum: Help & Support
Last Post: ardentcrest
2025-11-04, 05:46 PM
» Replies: 3
» Views: 1,394

A Fast(er) Plot Routine f...
Forum: How-To & Tutorials
Last Post: tubz74
2025-10-30, 03:16 PM
» Replies: 2
» Views: 1,478

Hall of Fame - Include fo...
Forum: How-To & Tutorials
Last Post: tubz74
2025-10-28, 03:48 PM
» Replies: 0
» Views: 818

[SOLVED] Array layout bug...
Forum: Bug Reports
Last Post: Zoran
2025-10-25, 05:48 PM
» Replies: 2
» Views: 1,539

The Towering Inferno

Posted by: zarsoft - 2023-09-27, 12:01 AM - Forum: Gallery - No Replies

	Click HERE to play online.

up7

Posted by: zarsoft - 2023-08-13, 09:30 PM - Forum: Gallery - No Replies

	Game up7 written in Pascalated BASIC. To play online, click HERE.

Microdrive or +3 Disk support when saving & loading

Posted by: jonesypeter - 2023-08-10, 06:40 PM - Forum: Help & Support - Replies (2)

	Hi, I'm creating an application with lots of arrays and wondered if the save and load commands support the microdrive syntax, or saving to +3 Disk? Many thanks Peter

Poker - Win Prizes playing videogames

Posted by: zarsoft - 2023-08-01, 02:58 PM - Forum: Gallery - No Replies

	Poker written in Pascalated BASIC. To play online, click HERE. (On the bottom of the page you have the link to play online and the link to download.)

TAP be gone

Posted by: zarsoft - 2023-07-29, 10:01 AM - Forum: Wishlist - Replies (2)

	I wish ".tap" not to appear in the name of the recorded bytes. "Game.tap" CODE 32768,12345 should be "Game" CODE 32768,12345 ".tap" already appears in the file name. It does not need to appear again in the recorded block header.

Pascalated ZX BASIC Demo #24 - Torpedo

Posted by: zarsoft - 2023-07-25, 08:18 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE

All Pascated BASIC demos are compiled with Boriel BASIC compiler just with BASIC without any assembly.

Code:
' PROGRAM Torpedo
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' Pascalated Sinclair BASIC (c) 1987 by ZarSoft
' Pascalated BASIC Converter (c) 2021 by Zarsoft
' Pascalated Boriel (c) 2023 by ZarSoft
' ZX BASIC Compiler (c) 2008 by Boriel

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

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

PROGRAM Torpedo

' CONSTant declarations
REM CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST yellow = 6
CONST white = 7
CONST MaxTorpedos = 23 : REM min = 23 = 2+2+3+3+4+4+5
CONST FleetDelay = 20 : REM fleet speed
CONST TorpedoDelay = 5 : REM torpedo speed
CONST DepthChargeDelay = 15 : REM depth charge timeout
'CONST Blank$ TYPE STRING = "                              " ' 30 blank spaces *** compiler error

' VAR - Global variables
VAR Blank$ TYPE STRING = "                              " ' 30 blank spaces *** should be CONST
VAR Zeros$ TYPE STRING = "000000000000000000000000000000" ' 30 zeros
VAR Fleet1$,Fleet2$ TYPE STRING ' fleet silhouette
VAR Value$ TYPE STRING ' value of ship
VAR Part$ TYPE STRING ' part number of ship
VAR Life$ TYPE STRING ' life of ship
VAR Hit$ TYPE STRING ' hits
VAR Smoke2$ TYPE STRING ' smoke of hits
VAR Smoke1$ TYPE STRING ' smoke of hits
VAR MaxScore TYPE INTEGER
VAR Heading TYPE INTEGER ' center at 200
VAR Rotation TYPE INTEGER ' periscope rotation
VAR Shield TYPE INTEGER = 100
VAR Hits TYPE INTEGER ' hits on target
VAR Sink TYPE INTEGER ' ships destroyed
VAR Score TYPE INTEGER ' Current score
VAR RiposteDamage TYPE REAL ' Riposte damage (from depth charge)
VAR INDEX TYPE INTEGER
VAR DepthChargeTime TYPE INTEGER
VAR Torpedos TYPE INTEGER
VAR GameOver TYPE BOOLEAN
VAR Period TYPE INTEGER = 8
VAR CLICK TYPE INTEGER ' animation sprite bit selection 0 to 7

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

PROCEDURE TRON (m$ TYPE STRING)
PRINT AT 0,17;TAB 31;
PRINT AT 0,17;INK 5;m$;
PAUSE 0
END PROCEDURE

'--- KEYBOARD BUFFER ---

VAR BUFFER$ TYPE STRING = ""
VAR LASTKEY$ TYPE STRING = ""

PROCEDURE ScanKey
VAR key$ TYPE STRING = INKEY$ + "#"
IF key$(0) <> LASTKEY$  
  LASTKEY$ = key(0)
  LET BUFFER$ = BUFFER$+key$(0)
ENDIF
END PROCEDURE

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

FUNCTION LastKey$ TYPE STRING
RETURN LASTKEY$
END FUNCTION

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

VAR Clock,Clock0 TYPE INTEGER

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

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

PROCEDURE SetSprites
POKE 23606,88 : POKE 23607,251-3*CLICK : REM Sprite
END PROCEDURE

PROCEDURE SetASCII
POKE 23606,0 : POKE 23607,60 : REM ZX Chars
END PROCEDURE

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

PROCEDURE TheEnd
BORDER 0
PRINT AT 3,14;PAPER 5;INK 2;"GAME";AT 4,14;"OVER"
IF Torpedos = 0 THEN PRINT AT 5,3;PAPER 0;INK 3;Torpedos;" ";
IF Shield = 0 THEN PRINT AT 8,1;PAPER 0;INK 3;INT(Shield+0.5);"% "
IF MaxScore < Score THEN LET MaxScore = Score
END PROCEDURE

PROCEDURE ShowFleet
SetSprites
PRINT AT 12,6;Fleet1$(INDEX+Rotation-10 TO INDEX+Rotation+10)
PRINT AT 11,6;Fleet2$(INDEX+Rotation-10 TO INDEX+Rotation+10)
PRINT AT 12,6;OVER 1;Smoke1$(INDEX+Rotation-10 TO INDEX+Rotation+10)
PRINT AT 11,6;OVER 1;Smoke2$(INDEX+Rotation-10 TO INDEX+Rotation+10)
SetASCII
END PROCEDURE

PROCEDURE ProcessDepthCharge
BORDER 2
LET Shield = Shield - RiposteDamage
IF Shield <= 0 THEN LET Shield = 0 : LET Score = Score - 500 : PRINT AT 21,26;PAPER 0;INK 7;"    ";AT 21,26;Score : LET GameOver = TRUE
PRINT AT 8,1;PAPER 0;INK 7;INT(Shield+0.5);"% "
END PROCEDURE

PROCEDURE SetSmokeHit
LET Hit$(INDEX+Rotation) = "1"
IF Hit$(INDEX+Rotation-1) = "0" AND Hit$(INDEX+Rotation+1) = "0"
  LET Smoke2$(INDEX+Rotation-1) = """"
  LET Smoke1$(INDEX+Rotation-1) = "#"
  LET Smoke2$(INDEX+Rotation) = "("
  LET Smoke1$(INDEX+Rotation) = ")"
ELSEIF Hit$(INDEX+Rotation-1) = "0" AND Hit$(INDEX+Rotation+1) = "1"
  LET Smoke2$(INDEX+Rotation-1) = """"
  LET Smoke1$(INDEX+Rotation-1) = "#"
  LET Smoke2$(INDEX+Rotation) = "$"
  LET Smoke1$(INDEX+Rotation) = "%"
ELSEIF Hit$(INDEX+Rotation-1) = "1" AND Hit$(INDEX+Rotation+1) = "0"
  LET Smoke2$(INDEX+Rotation-1) = "$"
  LET Smoke1$(INDEX+Rotation-1) = "%"
  LET Smoke2$(INDEX+Rotation) = "("
  LET Smoke1$(INDEX+Rotation) = ")"
ELSEIF Hit$(INDEX+Rotation-1) = "1" AND Hit$(INDEX+Rotation+1) = "1"
  LET Smoke2$(INDEX+Rotation-1) = "$"
  LET Smoke1$(INDEX+Rotation-1) = "%"
  LET Smoke2$(INDEX+Rotation) = "$"
  LET Smoke1$(INDEX+Rotation) = "%"
ENDIF
END PROCEDURE

PROCEDURE SetSmokeSink (ShipStart TYPE INTEGER, ShipValue TYPE INTEGER)
VAR i TYPE INTEGER
LET i = 0
LET Smoke2$(ShipStart+i-1) = """"
LET Smoke1$(ShipStart+i-1) = "#"
FOR i = 1 TO ShipValue*2-1
  ' PRINT AT 12,16;PAPER 8;INK 2;OVER 1;" ";
  LET Smoke2$(ShipStart+i-1) = "$"
  LET Smoke1$(ShipStart+i-1) = "%"
NEXT i
LET i = ShipValue*2
LET Smoke2$(ShipStart+i-1) = "("
LET Smoke1$(ShipStart+i-1) = ")"
END PROCEDURE

' invoqued if Value$(INDEX+Rotation) > "0" 
PROCEDURE ProcessHit
VAR ShipStart TYPE INTEGER
VAR ShipValue TYPE INTEGER
LET ShipValue = VAL Value$(INDEX+Rotation)
' hit
PRINT AT 12,16;PAPER 8;INK 2;OVER 1;" ";
IF Hit$(INDEX+Rotation) = "1" ' hit on old position
  LET Score = Score + ShipValue
  PRINT AT 21,26;PAPER 0;INK 7;"    ";AT 21,26;Score
ELSE  ' hit on new position
  LET Score = Score + 10 * ShipValue
  PRINT AT 21,26;PAPER 0;INK 7;"    ";AT 21,26;Score
  LET Hit$(INDEX+Rotation) = "1" 
  SetSmokeHit
  LET Hits = Hits + 1
  PRINT AT 5,28;PAPER 0;INK 7;Hits
  'LET Value$(INDEX+Rotation) = "0"
  LET ShipStart = (INDEX+Rotation) - VAL Part$(INDEX+Rotation)
  LET Life$(ShipStart) = STR$ ( VAL Life$(ShipStart) - 1 )
  IF Life$(ShipStart) = "0" 
    LET Sink = Sink + 1
    PRINT AT 8,28;PAPER 0;INK 7;Sink;" ";
    LET Score = Score + 10*ShipValue*ShipValue
    PRINT AT 21,26;PAPER 0;INK 7;"    ";AT 21,26;Score
    SetSmokeSink (ShipStart,ShipValue)
  ENDIF  
  BEEP .02,0 : BEEP .02,1 : BEEP .02,4 : BEEP .02,-1 :
ENDIF
END PROCEDURE

PROCEDURE FireTorpedo
VAR elapsed TYPE INTEGER
VAR ShipValue TYPE INTEGER
' update number of torpedos
LET Torpedos = Torpedos - 1
PRINT AT 5,3;PAPER 0;INK 7;Torpedos;" ";
' first half way
FOR CLICK = 0 TO 7
  ShowFleet
  PLOT PAPER 1;INK 7;131,35+3*CLICK : DRAW PAPER 1;INK 7;-2*(16-CLICK)*RND,0
  PLOT PAPER 1;INK 7;131,35+3*CLICK : DRAW PAPER 1;INK 7;2*(16-CLICK)*RND,0
  REPEAT
    ' time
    LET Clock = PEEK 23672
    LET elapsed = Clock-Clock0
    IF elapsed<0 THEN LET elapsed = elapsed+256
  UNTIL elapsed >= Period
  LET Clock0 = Clock0 + Period: IF Clock0 > 255 THEN LET Clock0 = Clock0 - 256
  ' process deaph charge
  BORDER 0
  IF DepthChargeTime THEN LET DepthChargeTime = DepthChargeTime - 1 : IF DepthChargeTime = 0 THEN ProcessDepthCharge
NEXT CLICK
CLICK = 0
LET INDEX = INDEX + 1 : ShowFleet
' second half way
FOR CLICK = 0 TO 7
  ShowFleet
  PLOT PAPER 1;INK 7;131,35+3*(CLICK+8) : DRAW PAPER 1;INK 7;-(16-(CLICK+8))*RND,0
  PLOT PAPER 1;INK 7;131,35+3*(CLICK+8) : DRAW PAPER 1;INK 7;(16-(CLICK+8))*RND,0
  REPEAT
    ' time
    LET Clock = PEEK 23672
    LET elapsed = Clock-Clock0
    IF elapsed<0 THEN LET elapsed = elapsed+256
  UNTIL elapsed >= Period
  LET Clock0 = Clock0 + Period: IF Clock0 > 255 THEN LET Clock0 = Clock0 - 256
  ' process deaph charge
  BORDER 0
  IF DepthChargeTime THEN LET DepthChargeTime = DepthChargeTime - 1 : IF DepthChargeTime = 0 THEN ProcessDepthCharge
NEXT CLICK
CLICK = 0
LET INDEX = INDEX + 1 : ShowFleet
' process hit
IF Value$(INDEX+Rotation) > "0" 
  ProcessHit
  REM ship riposte
  LET ShipValue = VAL Value$(INDEX+Rotation)
  LET RiposteDamage = ShipValue*(1+1.0*RND)
  LET DepthChargeTime = DepthChargeDelay-INT(RND*5)
ENDIF  
' delete torpedo trail
PRINT AT 13,16;PAPER 1;    " "
PRINT AT 14,16;PAPER 1;    " "
PRINT AT 15,15;PAPER 1;   "   "
PRINT AT 16,14;PAPER 1;  "     "
PRINT AT 17,13;PAPER 1; "       "
PRINT AT 18,12;PAPER 1;"         "
PRINT AT 19,12;PAPER 1;"         "
END PROCEDURE

PROCEDURE ShowKeys
PRINT AT 23,0;PAPER 0;INK 5;"           Keys: 12 0         "
END PROCEDURE

PROCEDURE InitFleet
VAR r TYPE INTEGER
PRINT AT 3,14;PAPER 5;"    ";AT 4,14;"    " : REM delete GAME OVER
'DIM Blank$(30)
LET Fleet1$ = Blank$
LET Fleet2$ = Blank$
LET Value$ = Zeros$
LET Part$ = Blank$
LET Life$ = Blank$
LET Hit$ = ""
LET Smoke2$ = ""
LET Smoke1$ = ""
FOR i = 1 TO 7
  PRINT AT 0,15;PAPER 0;INK 7;5*i;"  ";
  LET r = 1+INT (RND*5)
  LET Fleet1$ = Fleet1$ + Blank$( TO r)
  LET Fleet2$ = Fleet2$ + Blank$( TO r)
  LET Value$ = Value$ + Value$( TO r)
  LET Part$ = Part$ + Part$( TO r)
  LET Life$ = Life$ + Life$( TO r)
  IF i = 1 OR i = 7 THEN LET Value$ = Value$ + "02222" : LET Fleet2$ = Fleet2$ + "     ": LET Fleet1$ = Fleet1$ + "+-/13" : LET Part$ = Part$ + " 0123" : LET Life$ = Life$ + " 2xxx"
  IF i = 2 OR i = 6 THEN LET Value$ = Value$ + "0333333" : LET Fleet2$ = Fleet2$ + "468:<>@": LET Fleet1$ = Fleet1$ + "579;=?A" : LET Part$ = Part$ + " 012345" : LET Life$ = Life$ + " 3xxxxx"
  IF i = 3 OR i = 5 THEN LET Value$ = Value$ + "044444444" : LET Fleet2$ = Fleet2$ + "BDFHJLNPR": LET Fleet1$ = Fleet1$ + "CEGIKMOQS" : LET Part$ = Part$ + " 01234567" : LET Life$ = Life$ + " 4xxxxxxx"
  IF i = 4 THEN LET Value$ = Value$ + "05555555555" : LET Fleet2$ = Fleet2$ + "TVXZ\\^`bdfh": LET Fleet1$ = Fleet1$ + "UWY[]_acegi" : LET Part$ = Part$ + " 0123456789" : LET Life$ = Life$ + " 5xxxxxxxxx"
  PAUSE 10
NEXT i
FOR i = 1 TO 3
  PRINT AT 0,15;PAPER 0;INK 7;35+i*5;"  ";
  LET Fleet1$ = Fleet1$ + "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
  LET Fleet2$ = Fleet2$ + Blank$
  LET Value$  = Value$  + "000000000000000000000000000000"
  LET Part$ = Part$ + Blank$
  LET Life$ = Life$ + Blank$
  PAUSE 10
NEXT i
FOR i = 1 TO LEN Fleet1$
  Hit$ = Hit$ + "0"
  Smoke2$ = Smoke2$ + " "
  Smoke1$ = Smoke1$ + " "
NEXT i
' init clock
LET Clock = PEEK 23672
LET Clock0 = Clock0 + Period
' PRINT LEN Fleet1$, LEN Fleet2$, LEN Value$, LEN Part$, LEN Life$, LEN Hit$, LEN Smoke2$, LEN Smoke1$ 
' PAUSE 0
' PRINT Fleet1$( TO 90);TAB 0;Value$( TO 90);TAB 0; Part$( TO 90);TAB 0; Life$( TO 90) 
' PAUSE 0
END PROCEDURE

PROCEDURE InitVariables
BORDER 0 : PAPER 5 : INK 0
LET GameOver = FALSE
InitFleet
LET INDEX = 30
LET Heading = 50+10*INT(10*RND)
LET Rotation = 0
PRINT AT 0,15;PAPER 0;INK 7;Heading+Rotation*5;"  ";
LET Torpedos = MaxTorpedos
PRINT AT 5,3;PAPER 0;INK 7;Torpedos;" ";
LET Shield = 100
PRINT AT 8,1;PAPER 0;INK 7;Shield;"% "
LET Hits = 0
PRINT AT 5,28;PAPER 0;INK 7;Hits;"  ";
LET Sink = 0
PRINT AT 8,28;PAPER 0;INK 7;Sink;" ";
LET Score = 0
PRINT AT 21,26;PAPER 0;INK 7;"    ";AT 21,26;Score
PRINT AT 21,3;PAPER 0;INK 7;MaxScore
LET DepthChargeTime = 0
END PROCEDURE

PROCEDURE Game
VAR key$ TYPE STRING
VAR TorpedoLoaded TYPE BOOLEAN
VAR elapsed TYPE INTEGER

InitVariables
ShowKeys
ShowFleet
LET Clock0 = PEEK 23672 + Period

REPEAT ' game

'PRINT AT 0,20;PAPER 6;INK 0;Clock0;"  ";

  TorpedoLoaded = FALSE

  FOR CLICK = 0 TO 7
  ShowFleet
  'PRINT AT 0,20;INDEX
  
  ' WaitClock
  REPEAT
      ScanKey
      LET key$ = GetKey$
      IF key$ = "1" AND NOT TorpedoLoaded THEN IF Heading+Rotation*5 > 0 THEN BEEP .02,10: LET Rotation = Rotation - 1 : PRINT AT 0,15;PAPER 0;INK 7;Heading+Rotation*5;"  " : ShowFleet
      IF key$ = "2" AND NOT TorpedoLoaded THEN IF Heading+Rotation*5 < 300 THEN BEEP .02,15: LET Rotation = Rotation + 1 : PRINT AT 0,15;PAPER 0;INK 7;Heading+Rotation*5;"  " : ShowFleet
      IF key$ = "0" AND NOT TorpedoLoaded AND Torpedos > 0 THEN PRINT AT 23,8;PAPER 0;INK 6;"Loading torpedo";: TorpedoLoaded = TRUE
      ' time
      LET Clock = PEEK 23672
      LET elapsed = Clock-Clock0
      IF elapsed<0 THEN LET elapsed = elapsed+256
    UNTIL elapsed >= Period
    LET Clock0 = Clock0 + Period: IF Clock0 > 255 THEN LET Clock0 = Clock0 - 256

    BORDER 0
    IF TorpedoLoaded THEN BEEP .01,5*(CLICK+RND)

    ' process deaph charge
    IF DepthChargeTime THEN LET DepthChargeTime = DepthChargeTime - 1 : IF DepthChargeTime = 0 THEN ProcessDepthCharge

  NEXT CLICK
  CLICK = 0

  LET INDEX = INDEX + 1 : ShowFleet : IF Fleet1$(INDEX-10) = "!" THEN LET GameOver = TRUE

  IF TorpedoLoaded THEN PRINT AT 23,8;PAPER 0;INK 7;"               ";: FireTorpedo

UNTIL GameOver
TheEnd
END PROCEDURE

PROCEDURE PressStart
VAR key$ TYPE STRING
PRINT AT 23,0;PAPER 0;INK 7;"           Press ";INK 2;"S";INK 7;"tart         ";
REPEAT 
  PAUSE(50)
  LET key$ = INKEY$
UNTIL key$ = "s" OR key$ = "S"
PRINT AT 3,14;PAPER 5;INK 2;"    ";AT 4,14;"    ": REM delete Game Over
PRINT AT 23,0;PAPER 0;INK 6;"       Scanning fleet...     "
RANDOMIZE
END PROCEDURE

PROCEDURE ShowScreen
BORDER 0: PAPER 0: INK 0
REM sky
PAPER 5: OVER 1
PRINT AT 1,15;"   "
PRINT AT 2,12;"         "
PRINT AT 3,10;"             "
PRINT AT 4,9;"               "
PRINT AT 5,8;"                 "
PRINT AT 6,8;"                 "
PRINT AT 7,8;"                  "
PRINT AT 8,7;"                   "
PRINT AT 9,7;"                   "
PRINT AT 10,7;"                   "
PRINT AT 11,7;"                    "
PRINT AT 12,7;"                    "
PAPER 1: OVER 1
PRINT AT 13,7;"                   "
PRINT AT 14,7;"                   "
PRINT AT 15,7;"                  "
PRINT AT 16,8;"                 "
PRINT AT 17,8;"                "
PRINT AT 18,9;"               "
PRINT AT 19,10;"            "
PRINT AT 20,12;"        "
PRINT AT 21,15;"   "
OVER 0
REM Instruments
PAPER 0 : INK 7
PRINT AT 0,7;"HEADING"
PRINT AT 4,0;"TORPEDOS"
PRINT AT 7,0;"SHIELD"
PRINT AT 4,27;"HITS"
PRINT AT 7,27;"SHIPS"
PRINT AT 20,25;"SCORE"
PRINT AT 20,0;"MAX SCORE"
PAPER 5 : INK 0
END PROCEDURE

PROCEDURE TestSprites
SetSprites
PRINT
PRINT "     "
PRINT "+-/13"
PRINT
PRINT "468:<>@"
PRINT "579;=?A"
PRINT
PRINT "BDFHJLNPR"
PRINT "CEGIKMOQS"
PRINT
PRINT "TVXZ\\^`bdfh"
PRINT "UWY[]_acegi"
PRINT
PRINT """$&("
PRINT "#%')"
PRINT
SetASCII
END PROCEDURE

PROCEDURE SaveShips
SAVE "ships" CODE 64600,96*8
END PROCEDURE

PROCEDURE LoadShips
LOAD "ships" CODE 64600
END PROCEDURE

PROCEDURE MainRoutine
ShowScreen
PressStart
REPEAT 
  Game
  PressStart
UNTIL FALSE
END PROCEDURE

PROGRAM Torpedo
' TestSprites: PAUSE 0
PRINT AT 23,7;PAPER 0;INK 4;"(c) 2023 by Zarsoft";
FOR n=0 TO 30: BEEP .01,n: NEXT n
PRINT AT 23,0;PAPER 0;INK 7;"Pascalated Boriel ZX BASIC demo";
PAUSE 3*50
MainRoutine
PRINT AT 23,10;INK 2;"The End"
END PROGRAM

Pascalated ZX BASIC Demo #23 - Space Invader

Posted by: zarsoft - 2023-07-16, 07:12 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE

Code:
' PROGRAM Space Invader
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' Pascalated Sinclair BASIC (c) 1987 by ZarSoft
' Pascalated BASIC Converter (c) 2021 by Zarsoft
' Pascalated Boriel (c) 2023 by ZarSoft
' ZX BASIC Compiler (c) 2008 by Boriel

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

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

PROGRAM SpaceInvader

' CONSTant declarations
REM CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST yellow = 6
CONST white = 7
CONST ZXscreen = 22528
CONST GameScreen = ZXscreen+4+4*32

' VAR - Global variables
VAR INKoff TYPE INTEGER = blue
VAR INKon TYPE INTEGER= cyan
VAR LEDoff TYPE INTEGER = INKoff+64
VAR LEDon TYPE INTEGER = INKon+64
VAR VIDEO(8,6) TYPE INTEGER ' video memory
VAR ADDR(8,6) TYPE INTEGER ' video address
VAR score1 TYPE INTEGER 
VAR score2 TYPE INTEGER
VAR score3 TYPE INTEGER
VAR PlayerLin TYPE INTEGER
VAR PlayerCol TYPE INTEGER
VAR MissileLin TYPE INTEGER
VAR MissileCol TYPE INTEGER
VAR BombLin TYPE INTEGER
VAR BombCol TYPE INTEGER
VAR MothershipLin TYPE INTEGER
VAR MothershipCol TYPE INTEGER
VAR MothershipInc TYPE INTEGER
VAR Enemies TYPE INTEGER
VAR ScrollState TYPE INTEGER
VAR ScrollLin TYPE INTEGER
VAR ScrollCol TYPE INTEGER
VAR GameOver TYPE BOOLEAN
' VAR Scroll TYPE INTEGER = VAL ("Scroll"+STR$ ScrollState)
VAR k$ TYPE CHAR 
VAR Period TYPE INTEGER = 16

'--- KEYBOARD BUFFER ---

VAR BUFFER$ TYPE STRING = ""
VAR LASTKEY$ TYPE STRING = ""

PROCEDURE ScanKey
VAR key$ TYPE STRING = INKEY$ + "#"
IF key$(0) <> LASTKEY$  
  LASTKEY$ = key(0)
  LET BUFFER$ = BUFFER$+key$(0)
ENDIF
END PROCEDURE

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

FUNCTION LastKey$ TYPE STRING
RETURN LASTKEY$
END FUNCTION

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

VAR Clock,Clock0 TYPE INTEGER

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

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

PROCEDURE InitADDR
VAR l,c TYPE INTEGER
FOR l=1 TO 8
  FOR c=1 TO 6
    ADDR(l,c) = GameScreen+l*64+c*3
    ' POKE ADDR(l,c),18
  NEXT c
NEXT l
END PROCEDURE

PROCEDURE ShipOFF (l TYPE INTEGER,c TYPE INTEGER)
VAR addr TYPE INTEGER
VIDEO(l,c) = 0
addr = ADDR(l,c)
POKE addr,LEDoff: POKE addr+1,LEDoff: POKE addr+2,LEDoff
END PROCEDURE

PROCEDURE ShipON (l TYPE INTEGER,c TYPE INTEGER)
VAR addr TYPE INTEGER
IF VIDEO(l,c) = 0 THEN VIDEO(l,c) = 1 ' do not change shield value
addr = ADDR(l,c)
POKE addr,LEDon: POKE addr+1,LEDon: POKE addr+2,LEDon
END PROCEDURE

PROCEDURE FireOFF (l TYPE INTEGER,c TYPE INTEGER)
VAR addr TYPE INTEGER
addr = ADDR(l,c)
IF VIDEO(l,c) = 0 THEN POKE addr+1,LEDoff
END PROCEDURE

PROCEDURE FireON (l TYPE INTEGER,c TYPE INTEGER)
VAR addr TYPE INTEGER
addr = ADDR(l,c)
IF VIDEO(l,c) = 0 THEN POKE addr+1,LEDon
END PROCEDURE

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

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

PROCEDURE ChangeColors
VAR l,c TYPE INTEGER
VAR oldOFF,oldON TYPE INTEGER
oldOFF = LEDoff
oldON = LEDon
INKoff = (black+blue)-INKoff
INKon = (red+cyan)-INKon
LEDoff = INKoff+64
LEDon = INKon+64
' update colors on screen
FOR l=2 TO 4 
  FOR c=7 TO 24
    IF ATTR(l,c) = oldOFF THEN PRINT AT l,c;OVER 1;BRIGHT 1;PAPER 8;INK LEDoff;" ";
    IF ATTR(l,c) = oldON THEN PRINT AT l,c;OVER 1;BRIGHT 1;PAPER 8;INK LEDon;" ";
  NEXT c
NEXT l
FOR l=6 TO 20 STEP 2
  FOR c=7 TO 24
    IF ATTR(l,c) = oldOFF THEN PRINT AT l,c;OVER 1;BRIGHT 1;PAPER 8;INK LEDoff;" ";
    IF ATTR(l,c) = oldON THEN PRINT AT l,c;OVER 1;BRIGHT 1;PAPER 8;INK LEDon;" ";
  NEXT c
NEXT l
END PROCEDURE

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

PROCEDURE ShowScore
IF score1 > 9 THEN LET score1 = score1-10: LET score2 = score2 + 1: IF score2 > 9 THEN LET score2 = score2-10: LET score3 = score3 + 1: IF score3 > 9 THEN LET score3 = score3-10
ShowDigit(1,score1)
ShowDigit(2,score2)
ShowDigit(3,score3)
END PROCEDURE

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

PROCEDURE NewWave
' Period for game speed
LET Period = Period-1: IF Period < 8 THEN LET Period = 8
' Enemies
LET VIDEO(2,1) = 1: LET VIDEO(2,2) = 1: LET VIDEO(2,3) = 1: LET VIDEO(2,4) = 1
LET VIDEO(3,1) = 1: LET VIDEO(3,2) = 1: LET VIDEO(3,3) = 1: LET VIDEO(3,4) = 1
LET Enemies = 8
' bombs and missiles 
LET BombLin = 0
LET BombCol = 0
LET MissileLin = 0
LET MissileCol = 0
' Scroll
LET ScrollState = 1
LET ScrollLin = 6
LET ScrollCol = 6
' refresh screen
FOR l=1 TO 8
  FOR c=1 TO 6
    IF VIDEO(l,c) = 0 
      ShipOFF(l,c)
    ELSE
      ShipON(l,c)
    ENDIF
  NEXT c
NEXT l
END PROCEDURE

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

PROCEDURE MoveLeft
VAR i TYPE INTEGER
IF PlayerCol > 1 
  ShipOFF(PlayerLin,PlayerCol)
  LET PlayerCol = PlayerCol - 1
  ShipON(PlayerLin,PlayerCol)
  BEEP .01,5
ENDIF
END PROCEDURE

PROCEDURE MoveRight
VAR i TYPE INTEGER
IF PlayerCol < 6
  ShipOFF(PlayerLin,PlayerCol)
  LET PlayerCol = PlayerCol + 1
  ShipON(PlayerLin,PlayerCol)
  BEEP .01,5
ENDIF
END PROCEDURE

PROCEDURE MissileFire
IF MissileLin = 0 
  IF VIDEO(7,PlayerCol) = 0  ' freeway
    LET MissileLin = 7
    LET MissileCol = PlayerCol
    FireON(MissileLin,MissileCol)
    BEEP .1,5
  ENDIF
ENDIF
END PROCEDURE

PROCEDURE MissileGo
FireOFF(MissileLin,MissileCol)
LET MissileLin = MissileLin-1
IF  MissileLin >= 1 ' free way
  IF VIDEO(MissileLin,MissileCol) = 0
    FireON(MissileLin,MissileCol)
  ELSE
    IF MissileLin = 1 ' hit on mothership
      ShipOFF(MissileLin,MissileCol): LET MothershipCol = 0
      LET score1 = score1 + 5: ShowScore
      LET MissileLin = 0
      BEEP .01,0: BEEP .01,10: BEEP .01,20: BEEP .01,30
    ELSE ' hit on ship
      ShipOFF(MissileLin,MissileCol) 
      LET Enemies = Enemies - 1: LET score1 = score1 + 2: ShowScore
      LET MissileLin = 0
      BEEP .01,0: BEEP .01,10: BEEP .01,20: BEEP .01,30 
      IF Enemies = 0 THEN NewWave: FOR n=0 TO 30: BEEP .01,n: NEXT n
    ENDIF  
  ENDIF
ENDIF
END PROCEDURE

PROCEDURE BombDrop
LET BombLin = 6
LET BombCol = 1+INT(RND*6)
WHILE VIDEO(BombLin,BombCol) = 0 AND BombLin >= 1
  LET BombLin = BombLin-1
END WHILE
IF BombLin = 1 
  LET BombLin = BombLin+1
  FireON(BombLin,BombCol)
ENDIF
END PROCEDURE

PROCEDURE BombGo
FireOFF(BombLin,BombCol)
LET BombLin = BombLin+1
IF BombLin = 9 
  REM ground zero
  LET BombLin = 0
ELSEIF VIDEO(BombLin,BombCol) = 0 ' free way
  FireON(BombLin,BombCol)
ELSEIF BombLin = 7 ' hit shield
  LET VIDEO(7,BombCol) = VIDEO(7,BombCol)-1: IF VIDEO(7,BombCol) = 0 THEN ShipOFF(7,BombCol): BEEP .2,30
  LET BombLin = 0
ELSEIF BombLin = 8 ' hit defender
  ShipOFF(PlayerLin,PlayerCol)
  LET BombLin = 0
  BEEP .2,5: BEEP .2,7: BEEP .2,0: BEEP .4,0
  LET GameOver = TRUE
ENDIF
END PROCEDURE

PROCEDURE MothershipStart
VAR i TYPE INTEGER
LET MothershipInc = -MothershipInc
LET MothershipCol = 1+5*(MothershipInc = -1)
ShipON(MothershipLin,MothershipCol)
END PROCEDURE

PROCEDURE MothershipGo
ShipOFF(MothershipLin,MothershipCol)
LET MothershipCol = MothershipCol + MothershipInc
IF MothershipCol < 1 OR MothershipCol > 6 
  LET MothershipCol = 0
ELSE
  ShipON(MothershipLin,MothershipCol)
ENDIF
END PROCEDURE

' scroll right
PROCEDURE Scroll1
VAR l TYPE INTEGER
REM shift ship
FOR l = 6 TO 2  STEP -1
  IF VIDEO(l,ScrollCol-1) > 0 THEN ShipON(l,ScrollCol): ShipOFF(l,ScrollCol-1)
NEXT l  
LET ScrollCol = ScrollCol-1
IF ScrollCol = 1 
  IF VIDEO(2,6) + VIDEO(3,6) + VIDEO(4,6) + VIDEO(5,6) + VIDEO(6,6) = 0 
    REM continue scroll right
    LET ScrollState = 1
    LET ScrollCol = 6
  ELSE
    REM goto scroll down (at right corner)
    LET ScrollState = 2
    LET ScrollCol = 6
    IF VIDEO(6,1) + VIDEO(6,2) + VIDEO(6,3) + VIDEO(6,4) + VIDEO(6,5) + VIDEO(6,6) > 0 THEN BEEP .1,5: BEEP .1,7: BEEP .1,0: BEEP .1,0: LET GameOver = TRUE
  ENDIF
ENDIF
END PROCEDURE

' scroll down (at right corner)
PROCEDURE Scroll2
VAR l TYPE INTEGER
REM shift ship
FOR l = 6 TO 3 STEP -1
  IF VIDEO(l-1,ScrollCol) > 0 THEN ShipON(l,ScrollCol): ShipOFF(l-1,ScrollCol)
NEXT l  
LET ScrollCol = ScrollCol-1
IF ScrollCol = 1 ' goto scroll left
  LET ScrollState = 3
  LET ScrollCol = 1
ENDIF
END PROCEDURE

' scroll left
PROCEDURE Scroll3
VAR i TYPE INTEGER
REM shift ship
FOR i = 6 TO 2  STEP -1
  IF VIDEO(i,ScrollCol+1) > 0 THEN ShipON(i,ScrollCol): ShipOFF(i,ScrollCol+1)
NEXT i  
LET ScrollCol = ScrollCol+1
IF ScrollCol = 6 
  IF VIDEO(2,1) + VIDEO(3,1) + VIDEO(4,1) + VIDEO(5,1) + VIDEO(6,1) = 0 
    REM continue scroll left
    LET ScrollState = 3
    LET ScrollCol = 1
  ELSE
    REM goto scroll down (at right corner)
    LET ScrollState = 4
    LET ScrollCol = 1
    IF VIDEO(6,1) + VIDEO(6,2) + VIDEO(6,3) + VIDEO(6,4) + VIDEO(6,5) + VIDEO(6,6) > 0 THEN BEEP .1,5: BEEP .1,7: BEEP .1,0: BEEP .1,0: LET GameOver = TRUE
  ENDIF
ENDIF
END PROCEDURE

' scroll down (at left corner)
PROCEDURE Scroll4
VAR l TYPE INTEGER
REM shift ship
FOR l = 6 TO 3 STEP -1
  IF VIDEO(l-1,ScrollCol) > 0 THEN ShipON(l,ScrollCol): ShipOFF(l-1,ScrollCol)
NEXT l  
LET ScrollCol = ScrollCol+1
IF ScrollCol = 6 ' goto scroll right
  LET ScrollState = 1
  LET ScrollCol = 5
ENDIF
END PROCEDURE

PROCEDURE Scroll
IF ScrollState = 1
  Scroll1
ELSEIF ScrollState = 2
  Scroll2
ELSEIF ScrollState = 3
  Scroll3
ELSEIF ScrollState = 4
  Scroll4
ENDIF  
END PROCEDURE

PROCEDURE ShowDigit0 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\: \ :";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\:.\.:";
END PROCEDURE

PROCEDURE ShowDigit1 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\  \ .";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\  \ :";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\  \ :";
END PROCEDURE

PROCEDURE ShowDigit2 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\..\.:";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\:.\..";
END PROCEDURE

PROCEDURE ShowDigit3 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\..\.:";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\..\.:";
END PROCEDURE

PROCEDURE ShowDigit4 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\. \ .";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\:.\.:";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\  \ :";
END PROCEDURE

PROCEDURE ShowDigit5 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\:.\..";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\..\.:";
END PROCEDURE

PROCEDURE ShowDigit6 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\:.\..";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\:.\.:";
END PROCEDURE

PROCEDURE ShowDigit7 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\  \ :";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\  \ :";
END PROCEDURE

PROCEDURE ShowDigit8 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\:.\.:";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\:.\.:";
END PROCEDURE

PROCEDURE ShowDigit9 (col TYPE INTEGER)
PRINT AT 2,col;BRIGHT 1;INK INKon;"\..\..";
PRINT AT 3,col;BRIGHT 1;INK INKon;"\:.\.:";
PRINT AT 4,col;BRIGHT 1;INK INKon;"\  \ :";
END PROCEDURE

PROCEDURE ShowDigit (ndigit TYPE INTEGER, value TYPE INTEGER)
VAR col TYPE INTEGER
LET col = 12+3*(3-ndigit)
IF value = 0 
  ShowDigit0 (col)
ELSEIF value = 1
  ShowDigit1 (col)
ELSEIF value = 2
  ShowDigit2 (col)
ELSEIF value = 3
  ShowDigit3 (col)
ELSEIF value = 4
  ShowDigit4 (col)
ELSEIF value = 5
  ShowDigit5 (col)
ELSEIF value = 6
  ShowDigit6 (col)
ELSEIF value = 7
  ShowDigit7 (col)
ELSEIF value = 8
  ShowDigit8 (col)
ELSEIF value = 9
  ShowDigit9 (col)
ENDIF  
END PROCEDURE

PROCEDURE ClearScreen
FOR i=2 TO 20
  PRINT AT i,7;OVER 1;BRIGHT 1;INK LEDoff;"                  ";
NEXT i
END PROCEDURE

PROCEDURE Game
VAR active TYPE INTEGER
VAR k$ TYPE STRING
VAR elapsed TYPE INTEGER

REPEAT

  REM process1
  'WaitClock
  REPEAT
    ScanKey
    LET k$ = GetKey$
    IF k$ = "1" THEN MoveLeft
    IF k$ = "2" THEN MoveRight
    IF k$ = "0" THEN MissileFire
    LET Clock = PEEK 23672
    LET elapsed = Clock-Clock0
    IF elapsed<0 THEN LET elapsed = elapsed+256
  UNTIL elapsed >= Period
  LET Clock0 = Clock0 + Period: IF Clock0 > 255 THEN LET Clock0 = Clock0 - 256

  LET active = MothershipCol
  IF NOT active THEN MothershipStart
  IF active THEN MothershipGo
  LET active = BombLin
  'IF Enemies > 3 THEN IF active+RND < ((score3+1.5)*10+score2)/50 THEN BombDrop
  IF NOT active THEN BombDrop
  IF active THEN BombGo
  IF MissileLin THEN MissileGo

  REM process2
  'WaitClock
  REPEAT
    ScanKey
    LET k$ = GetKey$
    IF k$ = "1" THEN MoveLeft
    IF k$ = "2" THEN MoveRight
    IF k$ = "0" THEN MissileFire
    LET Clock = PEEK 23672
    LET elapsed = Clock-Clock0
    IF elapsed<0 THEN LET elapsed = elapsed+256
  UNTIL elapsed >= Period
  LET Clock0 = Clock0 + Period: IF Clock0 > 255 THEN LET Clock0 = Clock0 - 256

  LET active = MothershipCol
  IF NOT active THEN MothershipStart
  IF active THEN MothershipGo
  LET active = BombLin
  'IF Enemies > 3 THEN IF active+RND < ((score3+1.5)*10+score2)/50 THEN BombDrop
  IF NOT active THEN BombDrop
  IF active THEN BombGo
  IF MissileLin THEN MissileGo

  REM process3
  Scroll

UNTIL GameOver
END PROCEDURE

PROCEDURE WaitForPlayer
PRINT AT 23,6;PAPER blue;INK white;" [s]            [c]";
REPEAT
  PAUSE 0
  LET k$ = INKEY$
  IF k$ = "c" THEN ChangeColors
UNTIL k$ = "s"
BEEP .4,5
RANDOMIZE
LET Clock0 = PEEK 23672
PRINT AT 23,6;PAPER blue;INK white;" [1][2]         [0]";
END PROCEDURE

PROCEDURE InitGame
VAR l,c TYPE INTEGER
LET Period = 16+1
' score
LET score1 = 0
LET score2 = 0
LET score3 = 0
ShowScore
' clear screen
FOR l=1 TO 8
  FOR c=1 TO 6
    VIDEO(l,c) = 0
  NEXT c
NEXT l
' Mothership
LET MothershipLin = 1
LET MothershipCol = 0
LET MothershipInc = -1
' defense shield
LET VIDEO(7,2) = 10: LET VIDEO(7,5) = 10
' Player
LET PlayerLin = 8
LET PlayerCol = 1
LET VIDEO(PlayerLin,PlayerCol) = 1
' new wave
NewWave
' extra
LET GameOver = FALSE
END PROCEDURE

PROCEDURE InitScreen
BORDER 1: PAPER 1: INK 7: CLS
PRINT AT 0,8;INK 7;"* SPACE INVADER *";
PAPER 0
FOR i=1 TO 21
  PRINT AT i,6;INK 1;"                    ";
NEXT i
PRINT AT 1,6;INK 7;"\:'\''\''\''\''\''\''\''\''\''\''\''\''\''\''\''\''\''\''\':";
FOR i=2 TO 20
  PRINT AT i,6;INK 7;"\: ";
  PRINT AT i,25;INK 7;"\ :";
NEXT i
PRINT AT 21,6;INK 7;"\:.\..\..\..\..\..\..\..\..\..\..\..\..\..\..\..\..\..\..\.:";
REM PLOT 11*8,176-2*8: DRAW 10*8,0: DRAW 0,-4*8+4: DRAW -10*8,0: DRAW 0,4*8-4
PRINT AT 2,12;INK INKoff;"\..\.. \..\.. \..\..";
PRINT AT 3,12;INK INKoff;"\:.\.: \:.\.: \:.\.:";
PRINT AT 4,12;INK INKoff;"\:.\.: \:.\.: \:.\.:";
PRINT AT 6,7;BRIGHT 1;INK INKoff;"\A\B\C\A\B\C\A\B\C\A\B\C\A\B\C\A\B\C";
FOR i=1 TO 5
  PRINT AT 6+i*2,7;BRIGHT 1;INK INKoff;"\D\E\F\D\E\F\D\E\F\D\E\F\D\E\F\D\E\F";
NEXT i
REM PRINT AT 18,7;INK INKoff;"   \G\H\I      \G\H\I";
REM PRINT AT 19,7;INK INKoff;" \E  \E  \E  \E  \E  \E ";
PRINT AT 18,7;BRIGHT 1;INK INKoff;"\M\E\N\M\E\N\M\E\N\M\E\N\M\E\N\M\E\N";
PRINT AT 20,7;BRIGHT 1;INK INKoff;"\J\K\L\J\K\L\J\K\L\J\K\L\J\K\L\J\K\L";
REM PRINT AT 23,7;INK 7;"12     keys     90";
PRINT AT 23,6;PAPER blue;INK white;" [1][2]         [0]";
END PROCEDURE

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

PROCEDURE DataChars
DATA "A"
DATA BIN 00000000
DATA BIN 00000011
DATA BIN 00000001
DATA BIN 00011111
DATA BIN 00111111
DATA BIN 01111111
DATA BIN 00111111
DATA BIN 00000111
DATA "B"
DATA BIN 00111100
DATA BIN 11111111
DATA BIN 01011010
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 00111100
DATA "C"
DATA BIN 00000000
DATA BIN 11000000
DATA BIN 10000000
DATA BIN 11111000
DATA BIN 11111100
DATA BIN 11111110
DATA BIN 11111100
DATA BIN 11100000
DATA "D"
DATA BIN 00000010
DATA BIN 00000010
DATA BIN 00000110
DATA BIN 00001111
DATA BIN 00001111
DATA BIN 00011100
DATA BIN 00010000
DATA BIN 00010000
DATA "E"
DATA BIN 00011000
DATA BIN 00111100
DATA BIN 01111110
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 01111110
DATA BIN 00111100
DATA BIN 00011000
DATA "F"
DATA BIN 01000000
DATA BIN 01000000
DATA BIN 01100000
DATA BIN 11110000
DATA BIN 11110000
DATA BIN 00110000
DATA BIN 00010000
DATA BIN 00001000
END PROCEDURE

PROCEDURE DataChars2
DATA "G"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000001
DATA BIN 00000111
DATA BIN 00011111
DATA BIN 01111111
DATA BIN 00000000
DATA BIN 00000000
DATA "H"
DATA BIN 00011000
DATA BIN 01111110
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 00000000
DATA BIN 00000000
DATA "I"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 10000000
DATA BIN 11100000
DATA BIN 11111000
DATA BIN 11111110
DATA BIN 00000000
DATA BIN 00000000
DATA "J"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00011111
DATA BIN 00111111
DATA BIN 01111111
DATA BIN 00111111
DATA BIN 00011110
DATA "K"
DATA BIN 00011000
DATA BIN 01111110
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 11111111
DATA BIN 00000000
DATA "L"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 11110000
DATA BIN 11111100
DATA BIN 11111110
DATA BIN 11111100
DATA BIN 01111000
DATA "M"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00001111
DATA BIN 00011111
DATA BIN 00111100
DATA BIN 01111000
DATA BIN 11110000
DATA "N"
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 00000000
DATA BIN 11110000
DATA BIN 11111000
DATA BIN 00111100
DATA BIN 00011110
DATA BIN 00001111
DATA ""
END PROCEDURE

PROCEDURE TellStory
BORDER 1: PAPER 1: INK 7: CLS
PRINT AT 5,0;"In 1980 was launched"
PRINT TAB 0;"the first handheld videogame:"
PRINT TAB 5;""
PRINT TAB 5;INK 6;"SPACE INVADER"
PRINT TAB 5;"  by Entex"
PRINT TAB 5;""
PRINT TAB 5;"Red leds screen"
PRINT TAB 5;"6 x 8 resolution"
PRINT TAB 5;"6 AA batteries"
PRINT TAB 5;""
PRINT TAB 0;"On youtube search:"
PRINT TAB 0;"  Entex Space Invader"
PAUSE 15*50
END PROCEDURE

PROCEDURE MainRoutine
TellStory
DefineChars
InitADDR
InitScreen
WaitForPlayer
InitGame
REPEAT 
  Game
  WaitForPlayer
  ClearScreen
  InitGame
UNTIL FALSE
END PROCEDURE

PROGRAM SpaceInvader
FOR n=0 TO 30: BEEP .01,n: NEXT n
PRINT AT 23,0;"Pascalated Boriel ZX BASIC demo";
PAUSE 3*50
MainRoutine
PRINT AT 21,10;INK 2;"The End"
END PROGRAM

Pascalated ZX BASIC Demo #22 - Eagle 1

Posted by: zarsoft - 2023-07-02, 01:33 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE

Code:
' PROGRAM Eagle1 (Lander)
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' Pascalated Sinclair BASIC (c) 1987 by ZarSoft
' Pascalated BASIC Converter (c) 2021 by Zarsoft
' Pascalated Boriel (c) 2023 by ZarSoft
' ZX BASIC Compiler (c) 2008 by Boriel

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

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

PROGRAM Eagle1

' CONSTant declarations
REM CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST yellow = 6
CONST white = 7
CONST Gravity TYPE REAL = 1.62 ' gravity on the moon
CONST K TYPE REAL = 0.25
CONST Thrust TYPE REAL = 1.1
CONST MaxFuel TYPE REAL = 300

' VAR - Global variables
REM VARiable declarations
VAR MinSpeed TYPE REAL = 999
VAR MaxScore TYPE INTEGER = -1
VAR U$(10) ' DIM U$(8,5) : REM Sprites, upper line
VAR V$(10) ' DIM V$(8,5) : REM Sprites, bottom line
VAR x TYPE INTEGER 
VAR y TYPE REAL 
VAR yy TYPE INTEGER
VAR Fuel TYPE REAL
VAR DY TYPE REAL
VAR Landed TYPE BOOLEAN 
VAR Score TYPE INTEGER
VAR T TYPE INTEGER
VAR Message TYPE INTEGER

PROCEDURE TRON (m$ TYPE STRING)
PRINT AT 23,0;INK 5;m$;
PAUSE 0
END PROCEDURE

PROCEDURE GetReady
PRINT AT 11,0;INK 5;"Press 1 to start"
REPEAT 
  PAUSE 0
UNTIL INKEY$ = "1"
PRINT AT 11,0;INK 5;"                "
END PROCEDURE

PROCEDURE Report
IF ABS DY < MinSpeed THEN LET MinSpeed = ABS DY
LET Score = INT(0.5+(2000+Fuel)/(2^ABS DY))
IF Score <= 1 THEN LET Score = 0
IF Score > MaxScore THEN LET MaxScore = Score
PRINT INK 6;AT 1,0;"Height:  ";0;"  "
PRINT INK 4;AT 3,0;"MinSpeed:";(STR$ MinSpeed+"    ")(0 TO 2)
PRINT INK 4;AT 4,0;"MaxScore:";MaxScore;
IF Score = 0 
  LET m$ = "You fell like a rock!"
  LET n$ = "Press 0 to Thrust."
  PRINT AT 21,15;OVER 1;PAPER 8;INK 3;"     ";
ELSEIF Score < 500
  LET m$ = "You are a beginner."
  LET n$ = "Try to be an amateur."
  PRINT AT 21,15;OVER 1;PAPER 8;INK 6;"     ";
ELSEIF Score < 1000
  LET m$ = "You are an amateur."
  LET n$ = "Try to be a professional."
  PRINT AT 21,15;OVER 1;PAPER 8;INK 5;"     ";
ELSE
  LET m$ = "You are a professional!"
  LET n$ = "You are wasting your time here!"
  PRINT AT 21,15;OVER 1;PAPER 8;INK 4;"     ";
ENDIF
PRINT AT 6,0;INK 3;"Score: ";Score
PRINT AT 8,0;INK 6;m$
PRINT AT 9,0;INK 6;n$
BEEP 0.1,0: BEEP 0.1,20: BEEP 0.1,10
REM wait a few seconds
LET T = PEEK 23672 + 3*50
IF T > 255 THEN LET T = T - 255
REPEAT
  PAUSE 1
UNTIL ABS (T - PEEK 23672) < 5
GetReady
PRINT AT 6,0;"            "
PRINT AT 8,0;INK 4;"                               "
PRINT AT 9,0;INK 4;"                               "
PRINT AT 20,15;"     ";
PRINT AT 21,15;"     ";
END PROCEDURE

FUNCTION DataStory TYPE STRING
VAR r$ TYPE STRING
IF Message = 1 
  r$ = "Hello!" 
ELSEIF Message = 2
  r$ = "Hello!" + CHR(13) + "Do you read me?"
ELSEIF Message = 3
  r$ = "This is Dr Helena Russel," 
ELSEIF Message = 4 
  r$ = "This is Dr Helena Russel," + CHR(13) + "calling Moonbase Alpha."
ELSEIF Message = 5 
  r$ = "We are in danger:" 
ELSEIF Message = 6 
  r$ = "We are in danger:" + CHR(13) + "Pilot Alan Carter is sick."
ELSEIF Message = 7 
  r$ = "You need to land the Eagle 1" 
ELSEIF Message = 8 
  r$ = "You need to land the Eagle 1" + CHR(13) + "by remote control."
ELSEIF Message = 9 
  r$ = "You are our only hope." + CHR(13) + "God help us!"
ENDIF
RETURN r$
END FUNCTION

PROCEDURE ClearStory
PRINT AT  8,0;
PRINT " ";TAB 0;" ";TAB 0;
PRINT " ";TAB 0;" ";TAB 0;
END PROCEDURE

PROCEDURE TellStory
VAR m$ TYPE STRING
ClearStory
m$ = DataStory
PRINT AT  8,0;INK 6;m$
BEEP 0.1,0: BEEP 0.1,20: BEEP 0.1,10
PAUSE 3*50
LET Message = Message + 1
END PROCEDURE

PROCEDURE DrawScreen
PRINT PAPER 2;INK 0;BRIGHT 1;AT 0, 22;" EAGLE 1 "
PRINT INK 6;AT 0,0;"Fuel:    ";Fuel;" "
PRINT INK 6;AT 1,0;"Height:  ";ABS INT y;" "
PRINT INK 5;AT 2,0;"Speed:   ";(STR$ ABS DY+"    ")(0 TO 2)
END PROCEDURE

PROCEDURE InitVariables
LET x = 150
LET y = 175-8
LET yy = y
LET Fuel = MaxFuel
LET DY = 0
LET Landed = FALSE
END PROCEDURE

PROCEDURE Lander
VAR lin TYPE INTEGER
VAR ix TYPE INTEGER
InitVariables
DrawScreen
IF MaxScore < 0 THEN GetReady
REPEAT
  LET k$ = INKEY$
  IF k$ = "0" AND Fuel > 0 
    BEEP .01,30: LET DY = DY + Thrust : LET Fuel = Fuel - 10
  ELSE
    BEEP .01,-28
  ENDIF  
  LET DY = DY - K*Gravity : REM Gravity
  LET y = y + DY
  LET yy = INT(y+0.5)
  IF yy < 0 THEN LET yy = 0 : LET Landed = TRUE
  IF yy > 175-8 THEN LET yy = 175-8
  LET lin = 21-INT (yy/8)
  LET ix = 1+yy-8*INT(yy/8)
  POKE 23606,88 : POKE 23607,251 : REM Sprite
  PRINT AT lin-1,15;U$(ix)(1 TO 5)
  PRINT AT lin,15;V$(ix)(1 TO 5)
  IF lin > 1 THEN PRINT AT lin-2,15;"     "; : IF ABS DY > 8 THEN PRINT AT lin-3,15;"     ";
  IF lin < 21 THEN PRINT AT lin+1,15;"     ";
  POKE 23606,0 : POKE 23607,60 : REM ZX Chars
  PRINT INK 6;AT 0,0;"Fuel:    ";Fuel;" "
  PRINT INK 6;AT 1,0;"Height:  ";ABS INT y;" "
  PRINT INK 5;AT 2,0;"Speed:   ";(STR$ ABS DY+"   ")(0 TO 2)
UNTIL Landed
Report
END PROCEDURE

PROCEDURE RestoreData (s TYPE INTEGER)
VAR b,r,n TYPE INTEGER
RESTORE
FOR b=1 TO s
  FOR r=0 TO 4
    READ n
  NEXT r
NEXT b
END PROCEDURE

PROCEDURE InitSprites
CONST RAMTOP = 23730 : REM (87,255) = 65367 = 65535-21*8
CONST SIZE = 936 : REM 96*8 + 21*8
CONST NEWTOP = 64599 : REM 65535-936
REM CLEAR 64599
CONST CHARS = 23606 : REM (0,61-1) = 15616-256
CONST CharsUDG = 65368 : REM USR "A" = 65368 = 65536-21*8
CONST CharsSprites = 64600 : REM 65536-21*8-96*8
REM CharsSprites POKE = (344,251)
VAR s,b,r,n TYPE INTEGER
VAR dest TYPE INTEGER
LET Message = 0
TellStory
' INIT STRINGS
FOR s=0 TO 7
  LET U$(s+1) = ":12345"
  LET V$(s+1) = ":12345"
NEXT s
REM Define Lines
LET n=32
FOR s=0 TO 7
  FOR c=0 TO 4
    LET U$(s+1)(c+1) = CHR$(n)
    LET n = n+1
  NEXT c
  FOR c=0 TO 4
    LET V$(s+1)(c+1) = CHR$(n)
    LET n = n+1
  NEXT c
NEXT s
REM Define Sprites
FOR s=7 TO 0 STEP -1
  TellStory
  RestoreData(s)
  LET dest = CharsSprites + 2*5*8*s
  REM upper line
  FOR b=0 TO 7
    FOR r=0 TO 4
      READ n
      POKE dest+b+r*8,n
      'TRON("POKE "+STR$ (dest+b+r*8) )
    NEXT r
  NEXT b
  LET dest = dest + 5*8
  REM bottom line
  FOR b=0 TO 7
    FOR r=0 TO 4
      READ n
      POKE dest+b+r*8,n
      'TRON("POKE "+STR$ (dest+b+r*8) )
    NEXT r
  NEXT b
  REM print eagle
  POKE 23606,88 : POKE 23607,251 : REM Sprite
  PRINT AT 0,15;V$(s+1)(1 TO );
  POKE 23606,0 : POKE 23607,60 : REM ZX Chars
  'TRON("s "+STR$ s)
NEXT s
' show sprites
IF FALSE
  CLS
  c = 1
  FOR s=0 TO 7
    ' upper
    c = 3-c: PAPER c
    PRINT U$(s+1);":";
    POKE 23606,88 : POKE 23607,251 : REM Sprite
    PRINT U$(s+1)(1 TO );
    POKE 23606,0 : POKE 23607,60 : REM ZX Chars
    PRINT ":"
    ' bottom
    c = 3-c: PAPER c
    PRINT V$(s+1);":";
    POKE 23606,88 : POKE 23607,251 : REM Sprite
    PRINT V$(s+1)(1 TO );
    POKE 23606,0 : POKE 23607,60 : REM ZX Chars
    PRINT ":"
  NEXT s
  PAUSE 0
  CLS
ENDIF
END PROCEDURE

PROCEDURE DataSprite
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 01111111, BIN 11111111, BIN 11111111, BIN 11100001
DATA BIN 00011110, BIN 11111111, BIN 11111111, BIN 11111111, BIN 11110111
DATA BIN 01111111, BIN 11111111, BIN 11111111, BIN 11111111, BIN 11111111
DATA BIN 01111111, BIN 11111111, BIN 11111111, BIN 11111111, BIN 11110111
DATA BIN 00011110, BIN 11111111, BIN 11111111, BIN 11111111, BIN 11100001
DATA BIN 00000000, BIN 00011110, BIN 00000000, BIN 00001111, BIN 00000000
DATA BIN 00000000, BIN 00001100, BIN 00000000, BIN 00000110, BIN 00000000
DATA BIN 00000000, BIN 00011110, BIN 00000000, BIN 00001111, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
DATA BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000, BIN 00000000
END PROCEDURE

PROCEDURE LoadBackground
BORDER 0 : PAPER 0 : INK 7 : CLS
LOAD "" SCREEN$
END PROCEDURE

PROGRAM Eagle1
REM CLEAR 64599
POKE 23606,0 : POKE 23607,60 : REM ZX Chars
PRINT AT 23,0;INK 3;"Pascalated Boriel ZX BASIC demo";
PAUSE 2*50
LoadBackground
InitSprites
ClearStory
REPEAT
  Lander
UNTIL FALSE
GameOver
END PROGRAM

Pascalated ZX BASIC Demo #21 - Fxy Graph

Posted by: zarsoft - 2023-06-24, 02:46 PM - Forum: Gallery - No Replies

To run online, click here: RUN ONLINE

Try these:
2*(x*x+y*y<1.5)
(x*x+y*y<1.5)*(2-x*x-y*y)

Code:
' PROGRAM ViewFxy
' (c) ZarSoft 2022 Pascalated BASIC
' (c) ZarSoft 2023 Pascalated Boriel ZX BASIC
' Written by Ze Oliveira
' Pascalated Sinclair BASIC (c) 1987 by ZarSoft
' Pascalated BASIC Converter (c) 2021 by Zarsoft
' Pascalated Boriel (c) 2023 by ZarSoft
' ZX BASIC Compiler (c) 2008 by Boriel

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

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

PROGRAM ViewFxy

' CONSTant declarations
REM CONSTant declarations
CONST black = 0
CONST blue = 1
CONST red = 2
CONST magenta = 3
CONST green = 4
CONST cyan = 5
CONST yellow = 6
CONST white = 7
CONST res TYPE INTEGER = 20 ' resolution
CONST zoom TYPE REAL = 10 ' resize

' VAR - Global variables
VAR nfunc TYPE INTEGER = 1 ' active function number
REM Fxy = VAL ("F"+STR$ nfunc)
VAR F$ TYPE STRING = "0.5*COS(ABS(x*y*12))"
VAR G$ TYPE STRING ' USER function (only X and Y accepted)
VAR X,Y TYPE REAL ' x,y of the PROCEDURE
VAR Z TYPE REAL ' z = f(x,y)
VAR Horizon(255) TYPE INTEGER ' horizon
VAR x1,y1, x2,y2 TYPE REAL ' view domain
VAR TheEnd TYPE BOOLEAN

PROCEDURE TRON (m TYPE STRING)
  PRINT AT 23,0;m;
  PAUSE 0
END PROCEDURE

FUNCTION VARaz (V$ TYPE STRING) TYPE REAL
VAR R TYPE REAL
IF V$ = "Z" 
  R = Z
ELSE IF V$ = "Y" OR V$ = "y"
  R = Y
ELSE IF V$ = "X" OR V$ = "x"
  R = X
ENDIF  
RETURN R
END FUNCTION

FUNCTION VALx$ (S$ TYPE STRING) TYPE STRING
VAR R$ TYPE STRING
R$ = ""
FOR i = 0 TO LEN S$ -1 
  IF S$(i) >= "A" 
    LET R$ = R$ + STR$ VARaz( S$(i) ) 
  ELSE
    LET R$ = R$ + S$(i)
  ENDIF  
NEXT i
RETURN R$ 
END FUNCTION

PROCEDURE DrawLineYY (sx0 TYPE INTEGER,sy0 TYPE INTEGER,sx TYPE INTEGER,sy TYPE INTEGER)
VAR swap TYPE BOOLEAN
VAR x,y TYPE INTEGER
VAR xi,yi TYPE REAL
VAR xs,ys TYPE INTEGER
VAR aux TYPE INTEGER
VAR dx TYPE REAL
LET swap = FALSE
IF sy0>sy THEN LET swap = TRUE: LET aux = sy0: LET sy0 = sy: LET sy = aux: LET aux = sx0: LET sx0 = sx: LET sx = aux
LET xi = sx0
LET yi = sy0
LET dx = (0.1+sx-sx0-0.1)/(0.1+sy-sy0-0.1)
FOR y = sy0 TO sy
  ' xi = xi
  yi = y
  xs = INT (xi+0.5)
  ys = y
  IF  Horizon(xs) < ys THEN LET Horizon(xs) = ys
  IF  Horizon(xs) > ys THEN LET ys = Horizon(xs)
  PLOT xs, ys
  LET xi = xi+dx
  ' LET yi = yi+1
NEXT y
IF swap THEN LET aux = sy0: LET sy0 = sy: LET sy = aux: LET aux = sx0: LET sx0 = sx: LET sx = aux
END PROCEDURE

PROCEDURE DrawLineXX (sx0 TYPE INTEGER,sy0 TYPE INTEGER,sx TYPE INTEGER,sy TYPE INTEGER)
VAR x,y TYPE INTEGER
VAR xi,yi TYPE REAL
VAR xs,ys TYPE INTEGER
VAR dy TYPE REAL
LET xi = sx0
LET yi = sy0
LET dy = (0.1+sy-sy0-0.1)/(sx-sx0)
FOR x = sx0 TO sx
  xi = x
  xs = x
  ys = INT (yi+0.5)
  IF Horizon(xs) < ys THEN LET Horizon(xs) = ys
  IF Horizon(xs) > ys THEN LET ys = Horizon(xs)
  PLOT xs,ys
  LET yi = yi+dy
  ' LET xi = xi+1
NEXT x
END PROCEDURE

PROCEDURE DrawLine (sx0 TYPE INTEGER,sy0 TYPE INTEGER,sx TYPE INTEGER,sy TYPE INTEGER)
IF sx-sx0 >= ABS(sy-sy0) THEN DrawLineXX(sx0,sy0,sx,sy)
IF sx-sx0 < ABS(sy-sy0) THEN DrawLineYY(sx0,sy0,sx,sy)
END PROCEDURE

FUNCTION F0 TYPE REAL
F$ = VALx$( G$ )
RETURN VAL( F$ )
END FUNCTION

FUNCTION F1 TYPE REAL
RETURN 9/(1+8*X*X+8*Y*Y)
END FUNCTION

FUNCTION F2 TYPE REAL
RETURN 9/(1+X*X*8+Y*Y*8)+0.25*COS(X*8+Y*8)
END FUNCTION

FUNCTION F3 TYPE REAL
RETURN -9/(1+8*X*X+8*Y*Y)
END FUNCTION

FUNCTION F4 TYPE REAL
RETURN 1*SIN(X*Y*6)/(X*Y*6+1.3E-5)
END FUNCTION

FUNCTION F5 TYPE REAL
RETURN 1.2*INT(3*(SIN(X*3)*SIN(X*3))*SIN(X*3)*(SIN(Y*3)*SIN(Y*3))*SIN(Y*3))
END FUNCTION

FUNCTION F6 TYPE REAL
RETURN SIN(X*3)*SIN(Y*3)
END FUNCTION

FUNCTION F7 TYPE REAL
RETURN INT(9/(1+8*X*X+8*Y*Y))
END FUNCTION

FUNCTION F8 TYPE REAL
RETURN 15*(X+Y)*EXP((-X*X*3-Y*Y*3))
END FUNCTION

FUNCTION F9 TYPE REAL
RETURN 7*COS(SQR(X*X*64+Y*Y*64))/(1+X*X*16+Y*Y*16)
END FUNCTION

FUNCTION Fxy TYPE REAL
VAR r TYPE REAL
IF nfunc = 0 
  r = F0
ELSEIF nfunc = 1 
  r = F1
ELSEIF nfunc = 2 
  r = F2
ELSEIF nfunc = 3 
  r = F3
ELSEIF nfunc = 4 
  r = F4
ELSEIF nfunc = 5 
  r = F5
ELSEIF nfunc = 6
  r = F6
ELSEIF nfunc = 7 
  r = F7
ELSEIF nfunc = 8 
  r = F8
ELSEIF nfunc = 9 
  r = F9
ENDIF  
RETURN r
END FUNCTION

PROCEDURE ShowGraph
VAR sx,sy TYPE INTEGER ' ortogonal screen coordinates
VAR sx0,sy0 TYPE REAL ' previous screen coordinates
VAR u,v TYPE INTEGER ' iterations 1 to res
VAR x0,y0 TYPE REAL ' previous x,y
VAR dx,dy TYPE REAL ' increment
VAR i TYPE INTEGER
BORDER 0 : PAPER 1 : INK 7 : CLS
PRINT "Function ";nfunc
IF nfunc = 0 THEN PRINT "F(x,y)= ";G$
REM DIM Horizon(255) : REM reset horizon
FOR i = 0 TO 255
  Horizon(i) = 0
NEXT i  
LET y0 = y1
LET dy = (y2-y1)/res
LET Y = y0
FOR v = 1 TO res
  LET u = 0
  LET x0 = x1
  LET dx = (x2-x1)/res
  LET X = x0
  Z = Fxy ' LET z = F1(x,y)
  LET sx0 = 52 + 10*u - INT(2.5*v)
  LET sy0 = 0 + INT(2.5*v) + INT(2.5*u) + INT(zoom*Z)
  
  LET Y = Y+dy
  
  FOR u = 1 TO res
    LET X = X+dx
    
    Z = Fxy ' LET z = F(x,y)
    
    LET sx = 52 + 10*u - INT(2.5*v)
    LET sy = 0 + INT(2.5*v) + INT(2.5*u) + INT(zoom*Z)
    ' PLOT sx,sy ' OK
    ' PLOT sx0,sy0: DRAW sx-sx0,sy-sy0 ' OK
    ' DrawLine(sx0,sy0,sx,sy)
    DrawLine( INT (0.5+sx0), INT (0.5+sy0), INT (0.5+sx), INT (0.5+sy) )
    
    LET sx0 = sx
    LET sy0 = sy
    IF INKEY$ <> "" THEN u = res
  NEXT u : REM for x
  
  IF INKEY$ <> "" THEN v = res
NEXT v : REM for y
END PROCEDURE

PROCEDURE WaitKey
PRINT AT 0,0;"Press any key to continue"
PAUSE(0)
END PROCEDURE

PROCEDURE ShowMenu
CLS
PRINT "MENU"
PRINT
PRINT "0 - Input function"
PRINT "1 - 9/(1+8*x*x+8*y*y)"
PRINT "2 - 9/(1+x*x*8+y*y*8)+0.25*COS(x*8+y*8)"
PRINT "3 - -9/(1+8*x*x+8*y*y)"
PRINT "4 - 1*SIN(x*y*6)/(x*y*6+1.3E-5)"
PRINT "5 - 1.2*INT(3*(SIN(x*3)*SIN(x*3))*SIN(x*3)*(SIN(y*3)*SIN(y*3))*SIN(y*3))"
PRINT "6 - SIN(x*3)*SIN(y*3)"
PRINT "7 - INT(9/(1+8*x*x+8*y*y))"
PRINT "8 - 15*(x+y)*EXP((-x*x*3-y*y*3))"
PRINT "9 - 7*COS(SQR(x*x*64+y*y*64))/(1+x*x*16+y*y*16)"
PRINT "Q - Quit"
PRINT
PRINT "Your command: "
END PROCEDURE

PROCEDURE ReadOption
LET TheEnd = FALSE
REPEAT 
  REPEAT 
    PAUSE(50)
    LET k$ = INKEY$
  UNTIL k$ <> ""
UNTIL (k$ >= "0" AND k$ <= "9") OR (k$ = "q")
IF k$ = "q" THEN LET TheEnd = TRUE
IF k$ <> "q" THEN LET nfunc = VAL(k$) ' : LET Fxy = VAL ("F"+STR$ nfunc)
IF nfunc = 0 THEN PRINT ,,"Only X and Y accepted.","You cannot use functions.","F(x,y)= "; : G$ = INPUT(80)
END PROCEDURE

PROCEDURE DefineFirstGraph
LET nfunc = 1
' LET Fxy = VAL ("F"+STR$ nfunc)
LET x1 = -PI/2: LET y1 = -PI/2
LET x2 = PI/2: LET y2 = PI/2
END PROCEDURE

PROGRAM ViewFxy
PRINT AT 23,0;"Pascalated Boriel ZX BASIC demo";
PAUSE 1*50
DefineFirstGraph
REPEAT 
  ShowGraph
  WaitKey
  ShowMenu
  ReadOption
UNTIL TheEnd
PRINT AT 21,10;INK 2;"The End"
END PROGRAM

VAL incomplete

Posted by: zarsoft - 2023-06-24, 12:54 PM - Forum: Wishlist - Replies (3)

	In ZX SPECTRUM: LET x = 2 PRINT VAL "2*x" Prints 4 But on the compiler gives 0 How about adding variables from "a" to "z" in VAL?

Pages (101): « Previous 1 … 7 8 9 10 11 … 101 Next »

Login
Username:
Password:	Lost Password?
	Remember me