Author Topic: A little Pascal programming…  (Read 1797 times)

0 Members and 1 Guest are viewing this topic.

Offline the graveborn

  • CPC464
  • **
  • Posts: 18
  • Country: gb
    • the graveborn
  • Liked: 7
  • Likes Given: 10
A little Pascal programming…
« on: 19:32, 01 July 19 »
The following is my solution to the second sub-problem of the "Three Homework Problems" problem posed by Programming Praxis; I'm just trying to solve the problems posed by the aforementioned 'site whilst I try to get a job - I was just fired in so passive a way that I'm not completely certain that I've been fired (I had - have..? - a "zero hour" job, and my employer just stopped offering me hours and responding to my emails :/ ) - and, having solved a fair few of the problems posed by the aforementioned 'site using a (kind of..?) retro Mac (an Apple Power Mac G4 (AGP Graphics) (450MHz processor, 1GB memory)), I decided to try to solve the problems posed by the aforementioned 'site using an Amstrad CPC and HiSoft Pascal for CP/M-80 and HiSoft Pascal Amstrad CPC464 to try to broaden my exposure to other platforms - particularly after I skimmed the documentation and realised that machine code could be intermixed with Pascal using arrays and the built-in ADDR function and USER procedure; but, if I'd done more than just skim the documentation, I would have realised that HiSoft Pascal Amstrad CPC464 doesn't provide any built-in functions or procedures for using files, and so I think that my using that platform - or at least that compiler - to try to solve the problems posed by the aforementioned 'site - and to try to program games - has ended almost as quickly as it began :/

(And I'm well-aware that my solutions to the problems posed by the aforementioned 'site are far from the best - but, in my defence, I don't have any traditional qualifications in computer science :/ )

PP150918.pas:

Code: [Select]
(* Programming Praxis *)
(* "Three Homework Problems" (18th of September, 2015) *)
(* [Sub-problem #2] *)

PROGRAM PP150918;

VAR
 i : 1..27;
 count (* (s) of letter(s) *) : ARRAY [ 1..26 ] OF 0..MAXINT;
 c : CHAR;
 first : BOOLEAN;
 number (* of letters *) : 0..26;
 were : BOOLEAN;
 k : 0..26;

FUNCTION fToLowercase( p : CHAR ) : CHAR;
BEGIN
 IF p IN [ 'A'..'Z' ] THEN
  fToLowercase := CHR( ORD( p ) - ORD( 'A' ) + ORD( 'a' ))
 ELSE
  fToLowercase := p
END;

BEGIN
 FOR i := 1 TO 26 DO
  count[ i ] := 0;
 WRITELN;
 WRITE( 'Please enter a string; ' );
 WRITE( 'this program will then count the number of occurences of each ' );
 WRITELN( 'letter in that string.' );
 WRITELN;
 WRITE( 'Your input: ' );
 REPEAT
  READ( c );
  c := fToLowercase( c );
  IF c IN [ 'a'..'z' ] THEN BEGIN
   i := ORD( c ) - ORD( 'a' ) + 1;
   count[ i ] := count[ i ] + 1
  END
 UNTIL EOLN;

 first := TRUE;
 number := 0;
 FOR i := 1 TO 26 DO
  IF count[ i ] > 0 THEN BEGIN
   IF first THEN BEGIN
    first := FALSE;
    were := count[ i ] > 1
   END;
   number := number + 1
  END;

 WRITELN;
 WRITE( 'There w' );
 IF ( number = 0 ) OR were THEN
  WRITE( 'ere' )
 ELSE
  WRITE( 'as' );
 WRITE( ' ' );
 IF number = 0 THEN
  WRITE( 'no letters' )
 ELSE BEGIN
  k := 0;
  FOR i := 1 TO 26 DO
   IF count[ i ] > 0 THEN BEGIN

    k := k + 1;
    IF k > 1 THEN
     IF number <> 2 THEN BEGIN
      WRITE( ', ' );
      IF k = number THEN
       WRITE( 'and ' )
     END ELSE
      WRITE( ' and ' );

    WRITE( count[ i ]:0, ' ''', CHR( i - 1 + ORD( 'a' )), '''' );
    IF count[ i ] > 1 THEN
     WRITE( 's' )
   END
 END;
 WRITELN( ' in the string that you entered.' )
END.

Offline AMSDOS

  • Supporter
  • 6128 Plus
  • *
  • Posts: 3.939
  • Country: au
    • index.php?action=treasury
    • Programs for Turbo Pascal 3
  • Liked: 1161
  • Likes Given: 1931
Re: A little Pascal programming…
« Reply #1 on: 12:56, 02 July 19 »
Hisoft Pascal 4t (or as you're calling it HiSoft Pascal Amstrad CPC464), has been designed to utilise much of the Amstrads Firmware, so for Games for example, it would be looking at simple games. Not that Simple Games can't be enjoyable, I coded 'Get the Cash' with it and towards the end of that project I felt like it was very close to pushing the limits on Hisoft Pascal 4t. I probably had some things in there I could have done better, for instance I was loading Sprite Driver/Graphics & Music. The Sprite Driver probably could have been some procedures which may have freed up some memory, I also used very descriptive names for the procedures, in Hisoft Pascal 4t only the Keywords are Tokenised, which leaves the names of procedures, variables and even variable types fully ASCII. The Hisoft Pascal 80 version would probably give more space to play with to compile programmes, it's only restriction being it only Compiles COM files for CP/M, while Hisoft Pascal 4t is pushing it's boundaries around 20k or so. It does allow like Turbo Pascal 3 to insert source code files at compile time and this does help free up space, though that was what I had to do to get my Game going.
You're correct in Hisoft Pascal for CPC464 doesn't have any standard File handling facilities. Within the Compiler is two non-standard commands called TIN(); and TOUT(); which Load and Save Files in a Character Format. They can be used to load Data into an Array or Saved from an Array, apart from that other the alternative is to write you own which involves using the Firmware.
The Firmware handling is one of Hisoft Pascal 4t strengths and can easily be accessed without any Machine Code necessary by allowing access to the Register Set through R variable. 'R' then follows on with any of the available registers the Amstrad has, so 'A','HL','DE','BC' for example. It can also use 'H','L' as single registers for example, so when single registers are used Hisoft Pascal needs to convert into Byte format which it does with the CHR(varname), this way when writing a PROCEDURE which carries out a operation a Numeric value can be passed through the PROCEDURE and then be converted where necessary. I hope that makes sense.
* Using the old Amstrad Languages :D   * with the Firmware :P
* I also like to problem solve code in BASIC :)   * And type-in Type-Ins! :D

Home Computing Weekly Programs
Popular Computing Weekly Programs
Your Computer Programs
Updated Other Program Links on Profile Page (Update April 16/15 phew!)
Programs for Turbo Pascal 3

Offline SRS

  • Supporter
  • 6128 Plus
  • *
  • Posts: 649
  • Country: de
  • Schneider CPC464 - what else ?
  • Liked: 652
  • Likes Given: 379
Re: A little Pascal programming…
« Reply #2 on: 23:17, 03 July 19 »
Nice :)
Just made me quickhack it in good ol' loco:
Code: [Select]
10 DIM a%(26)
20 PRINT"Please enter a string this program will then count the number of occurences of each letter in that string."
30 INPUT a$:a$=UPPER$(a$)
40 FOR i%=1 TO LEN(a$):m$=MID$(a$,i%,1)
50 PRINT m$
60 a%(ASC(m$)-64)=a%(ASC(m$)-64)+1
70 NEXT
80 PRINT"string was made of "
90 FOR i%=1 TO 26
100 IF a%(i%)>0 THEN PRINT a%(i%);" times ";CHR$(i%+64)
110 NEXT

Offline the graveborn

  • CPC464
  • **
  • Posts: 18
  • Country: gb
    • the graveborn
  • Liked: 7
  • Likes Given: 10
Re: A little Pascal programming…
« Reply #3 on: 11:14, 26 July 19 »
@AMSDOS Thank you for your reply! I think I already knew about everything that you wrote about - eg., I already knew about the built-in Rx variables, although those aren't how I've been intermixing machine code and Pascal - I've posted below a proof-of-concept of my (likely bad...) idea for intermixing machine code and Pascal using arrays and the built-in ADDR function and POKE and USER procedures; my (better, but still likely bad...) idea was for the executable to read machine code from file at run-time, thus - amongst other things - reducing the size of the source code and the size of the executable, as it isn't necessary to have line after line after... of calls to the POKE procedure; I've now put together quick-and-(very...)dirty functions for file handling (again intermixing machine code and Pascal), and I'll try to post them "soon"...

On that topic, do you know if the Z80 in the Amstrad CPC supports the IX (#DDxx) instructions? (If you don't know, I'll perform an experiment to determine if it does or doesn't.) I ask as I discovered that the Z80 in the Amstrad CPC seems not to support the bit (#CBxx) instructions. (I'm using the tables here for reference.)

PoC.pas:

Code: [Select]
(*$C-*)

(* This program is a proof-of-concept that demonstrates using `HiSoft Pascal *)
(* Amstrad CPC464` to intermix machine code and Pascal using arrays and the  *)
(* built-in `ADDR` function and `POKE` and `USER` procedures.                *)

(* This program interrogates the state of joystick #0.                       *)

PROGRAM PoC (* "Proof-of-Concept" *) ;

CONST
 kMCLength = 31;

TYPE
 tJoystick = ARRAY [ 0..5 ] OF BOOLEAN;
 (* Bit/index: Meaning:      *)
 (* 0          d-pad up      *)
 (* 1          d-pad down    *)
 (* 2          d-pad left    *)
 (* 3          d-pad right   *)
 (* 4          fire button 2 *)
 (* 5          fire button 1 *)
 tPositiveInteger = 1..MAXINT;
 tJoystickAxisDirection = -1..1;
 tJoystickButton = 1..2;

VAR
 MCOffset, MCAddress : INTEGER;
 MC : ARRAY [ 1..kMCLength ] OF CHAR;
 joystick0 : tJoystick;
 jumpAddress, callAddress : INTEGER;
 first : BOOLEAN;
 oldJoystick0 : tJoystick;
 i : 0..6;

PROCEDURE pPokeMC( value : INTEGER; sizeOfValue (* in bytes *) :
                   tPositiveInteger );
BEGIN
 IF MCOffset + sizeOfValue > kMCLength THEN BEGIN
  WRITE( 'Sorry, an error occurred: too much machine code has already been ' );
  WRITELN( '`POKE`''d (`MCOffset` + `sizeOfValue` > `kMCLength`).' );
  HALT
 END;
 POKE( MCAddress + MCOffset, value );
 MCOffset := MCOffset + sizeOfValue
END;

FUNCTION fJoystickStateChanged( a, b : tJoystick ) : BOOLEAN;
VAR
 returnValue : BOOLEAN;
 i : 0..6;
BEGIN
 returnValue := FALSE;
 i := 0;
 WHILE NOT returnValue AND ( i <= 5 ) DO BEGIN
  returnValue := a[ i ] <> b[ i ];
  i := i + 1
 END;
 fJoystickStateChanged := returnValue
END;

FUNCTION fJoystickAxisDirection( joystick : tJoystick; axis : CHAR ) :
         tJoystickAxisDirection;
VAR
 p, n : 0..3;
 returnValue : tJoystickAxisDirection;
BEGIN
 IF axis IN [ 'x', 'X' ] THEN BEGIN
  p := 3;
  n := 2
 END ELSE BEGIN
  p := 0;
  n := 1
 END;
 IF NOT joystick[ p ] AND NOT joystick[ n ] THEN
  returnValue := 0
 ELSE
  IF joystick[ p ] AND joystick[ n ] THEN
   returnValue := 0
  ELSE
   IF joystick[ p ] THEN
    returnValue := 1
   ELSE
    returnValue := -1;
 fJoystickAxisDirection := returnValue
END;

PROCEDURE pWriteJoystickButtonState( joystick : tJoystick; button :
          tJoystickButton );
VAR
 i : 4..5;
BEGIN
 IF button = 1 THEN
  i := 5
 ELSE
  i := 4;
 WRITE( ' Fire button #', button:0, ': ' );
 IF NOT joystick[ i ] THEN
  WRITE( 'up' )
 ELSE
  WRITE( 'down' );
 WRITELN
END;

BEGIN
 MCAddress := ADDR( MC );
 MCOffset := 0;

 pPokeMC( #CD, 1 );   (* call ** *)
 pPokeMC( #BB24, 2 ); (* address #BB24 *)
 pPokeMC( #57, 1 );   (* ld d, a *)
 pPokeMC( #06, 1 );   (* ld b, * *)
 pPokeMC( #01, 1 );   (* value #01 *)
 pPokeMC( #0E, 1 );   (* ld c, * *)
 pPokeMC( #06, 1 );   (* value #06 *)
 pPokeMC( #21, 1 );   (* ld hl, ** *)
 pPokeMC( ADDR( joystick0 ), 2 );

 jumpAddress := MCAddress + MCOffset;

 pPokeMC( #36, 1 );   (* ld (hl), * *)
 pPokeMC( #00, 1 );   (* value #00 *)
 pPokeMC( #7A, 1 );   (* ld a, d *)
 pPokeMC( #A0, 1 );   (* and b *)

 pPokeMC( #C4, 1 );   (* call nz, ** *)
 callAddress := MCAddress + MCOffset;
 pPokeMC( #DEAD, 2 ); (* placeholder address *)

 pPokeMC( #78, 1 );   (* ld a, b *)
 pPokeMC( #87, 1 );   (* add a, a *)
 pPokeMC( #47, 1 );   (* ld b, a *)
 pPokeMC( #0D, 1 );   (* dec c *)
 pPokeMC( #23, 1 );   (* inc hl *)
 pPokeMC( #C2, 1 );   (* jp nz, ** *)
 pPokeMC( jumpAddress, 2 );

 pPokeMC( #C9, 1 );   (* ret *)

 POKE( callAddress, MCAddress + MCOffset );
 pPokeMC( #36, 1 );   (* ld (hl), * *)
 pPokeMC( #01, 1 );   (* value #01 *)
 pPokeMC( #C9, 1 );   (* ret *)

 first := TRUE;
 WHILE TRUE DO BEGIN
  USER( MCAddress );
  IF first OR fJoystickStateChanged( joystick0, oldJoystick0 ) THEN BEGIN
   first := FALSE;
   oldJoystick0 := joystick0;
   PAGE;
   WRITELN( 'Joystick #0:' );
   FOR i := 0 TO 5 DO
    WRITELN( ' Bit #', i:0, ': ', joystick0[ i ] );
   WRITELN;
   WRITE( ' y-axis: ' );
   CASE fJoystickAxisDirection( joystick0, 'y' ) OF
    -1:WRITE( 'down' );
    0:WRITE( 'neutral' );
    1:WRITE( 'up' )
   END;
   WRITELN;
   WRITE( ' x-axis: ' );
   CASE fJoystickAxisDirection( joystick0, 'x' ) OF
    -1:WRITE( 'left' );
    0:WRITE( 'neutral' );
    1:WRITE( 'right' )
   END;
   WRITELN;
   pWriteJoystickButtonState( joystick0, 1 );
   pWriteJoystickButtonState( joystick0, 2 )
  END
 END
END.
« Last Edit: 11:27, 26 July 19 by the graveborn »

Offline zhulien

  • 6128 Plus
  • ******
  • Posts: 786
  • Country: au
  • aka Vorax
    • 8bitology
  • Liked: 319
  • Likes Given: 339
Re: A little Pascal programming…
« Reply #4 on: 16:56, 26 July 19 »
Nice :)
Just made me quickhack it in good ol' loco:
Code: [Select]
10 DIM a%(26)
20 PRINT"Please enter a string this program will then count the number of occurences of each letter in that string."
30 INPUT a$:a$=UPPER$(a$)
40 FOR i%=1 TO LEN(a$):m$=MID$(a$,i%,1)
50 PRINT m$
60 a%(ASC(m$)-64)=a%(ASC(m$)-64)+1
70 NEXT
80 PRINT"string was made of "
90 FOR i%=1 TO 26
100 IF a%(i%)>0 THEN PRINT a%(i%);" times ";CHR$(i%+64)
110 NEXT


I remember a guy trying to tutor this in YouTube and saying how such logic is really bad and instead was coming up with a faster logic that uses more memory but less iterations.  I told him, he shouldn't be teaching his students that one method was bad without reason because if the goal is to conserve memory or eg: run on a CPC in BASIC, then such a solution like yours is very good.  Sad when lecturers assume a single target platform when teaching algorithms.

Offline AMSDOS

  • Supporter
  • 6128 Plus
  • *
  • Posts: 3.939
  • Country: au
    • index.php?action=treasury
    • Programs for Turbo Pascal 3
  • Liked: 1161
  • Likes Given: 1931
Re: A little Pascal programming…
« Reply #5 on: 01:17, 27 July 19 »

On that topic, do you know if the Z80 in the Amstrad CPC supports the IX (#DDxx) instructions? (If you don't know, I'll perform an experiment to determine if it does or doesn't.) I ask as I discovered that the Z80 in the Amstrad CPC seems not to support the bit (#CBxx) instructions. (I'm using the tables here for reference.)



I'm not sure if I could provide a satisfactory answer, Index Registers are available through the INLINE M/C Command, Hisoft Pascal manages it a little differently compared to when used from BASIC or Assembly depending on how variables are defined (Globally, Locally or from a Procedure Statement or Function) which are outlined in one of the Appendixes of the Manual. If you're looking at the Index Registers from a Bit Instruction perspective (DDCB), then I can't help with that.  :'(
* Using the old Amstrad Languages :D   * with the Firmware :P
* I also like to problem solve code in BASIC :)   * And type-in Type-Ins! :D

Home Computing Weekly Programs
Popular Computing Weekly Programs
Your Computer Programs
Updated Other Program Links on Profile Page (Update April 16/15 phew!)
Programs for Turbo Pascal 3

Offline the graveborn

  • CPC464
  • **
  • Posts: 18
  • Country: gb
    • the graveborn
  • Liked: 7
  • Likes Given: 10
Re: A little Pascal programming…
« Reply #6 on: 16:50, 05 March 20 »
The following is my solution to the "Reverse Vowels" problem posed by Programming Praxis, and is known to run on an emulated (using Arnold 1.7.8 ) Amstrad CPC 6128 on both CP/M Plus 1.0 (my solution compiled using HiSoft Pascal for CP/M-80) and AmsDOS (my solution compiled using HiSoft Pascal Amstrad CPC464).

Whilst solving this problem I learnt that, unlike Metrowerks CodeWarrior IDE 2.1 (Discover Programming Edition), the compiler that I'd usually use when using the Pascal programming language, HiSoft Pascal for CP/M-80 doesn't support a SET being a CONST - generating the compile-time error 13 ("Constant expected."); and that HiSoft' doesn't support the name of a source code file that is included using the (*$F <Filename>.PAS*) compiler directive containing lowercase letters in the non-suffix part of the name of that file - generating the compile-time error "No Source File: <FILENAME>.PAS" - as is illustrated by the following table:

Name of included source code fileGenerates compile-time error
<Filename>.pasYes
<Filename>.PASYes
<FILENAME>.pasNo
<FILENAME>.PASNo

I also learnt that Metrowerks' supports the conditional exclusion of source code using the (*$IFNOTC DEFINED __MWERKS__*) and (*$ENDC*) compiler directives.

(I'm just trying to solve the problems posed by the aforementioned 'site whilst I try to get a job (and I've solved this problem in particular to investigate using dynamic memory in HiSoft' - dynamic memory in HiSoft' seems to be a lot less sophisticated than in Metrowerks', but that lack of sophistication may have its advantage, and I'll most likely try to investigate that in my solution to another problem...); I'm well-aware that my solutions are far from the best - but, in my defence, I don't have any traditional qualifications in computer science :/ )

PP190604.pas:

Code: [Select]
(* Programming Praxis *)
(* "Reverse Vowels" (4th of June, 2019) *)

PROGRAM PP190604;

CONST
 kMaximumNumberOfCharactersPerStringNode = 5;

TYPE
 tZeroOrPositiveInteger = 0..MAXINT;
 tStringNode = RECORD
  mPreviousNode, mNextNode : ^tStringNode;
  mLengthOfString : tZeroOrPositiveInteger;
  mString : ARRAY [ 1..kMaximumNumberOfCharactersPerStringNode ] OF CHAR
 END;

VAR
 originalHeapState : ^tStringNode;

 firstChar : BOOLEAN;
 firstNode, currentNode : ^tStringNode;
 c : CHAR;

 headNode : ^tStringNode;
 headIndex : tZeroOrPositiveInteger;
 tailNode : ^tStringNode;
 tailIndex : tZeroOrPositiveInteger;
 vowels : SET OF CHAR;
 newHeadVowel, newTailVowel : CHAR;

 i : 1..MAXINT;

(*$F SETMODE2.PAS*)

(*$F OS      .PAS*)

FUNCTION fEnd:BOOLEAN;
VAR
 b : BOOLEAN;
BEGIN
 b := FALSE;
 IF headNode = NIL THEN
  b := TRUE
 ELSE IF tailNode = NIL THEN
  b := TRUE
 ELSE IF headNode = tailNode THEN
  b := headIndex >= tailIndex;
 fEnd := b
END;

(*$F LOWRCASE.PAS*)

PROCEDURE pIncrementHeadIndex;
BEGIN
 headIndex := headIndex + 1;
 IF headIndex > headNode^.mLengthOfString THEN BEGIN
  headNode := headNode^.mNextNode;
  headIndex := 1
 END
END;

PROCEDURE pDecrementTailIndex;
BEGIN
 tailIndex := tailIndex - 1;
 IF tailIndex = 0 THEN BEGIN
  tailNode := tailNode^.mPreviousNode;
  IF tailNode <> NIL THEN
   tailIndex := tailNode^.mLengthOfString
 END
END;

(*$F UPPRCASE.PAS*)

BEGIN
 MARK( originalHeapState );

 pChangeScreenMode;
 IF fOSIsCPM THEN
  WRITELN;
 WRITE( 'Please enter a string; this program will then reverse the vowels in' );
 WRITE( ' that string,' );
 WRITELN( 'maintaining the original capitalisation of the vowels.' );
 WRITELN;
 WRITE( 'Your input: ' );
 firstChar := TRUE;
 NEW( firstNode );
 currentNode := firstNode;
 currentNode^.mPreviousNode := NIL;
 currentNode^.mNextNode := NIL;
 currentNode^.mLengthOfString := 0;
 REPEAT
  READ( c );
  IF NOT firstChar THEN BEGIN
   IF currentNode^.mLengthOfString = kMaximumNumberOfCharactersPerStringNode
   THEN BEGIN
    NEW( currentNode^.mNextNode );
    currentNode^.mNextNode^.mPreviousNode := currentNode;
    currentNode := currentNode^.mNextNode;
    currentNode^.mNextNode := NIL;
    currentNode^.mLengthOfString := 0
   END;
   currentNode^.mLengthOfString := currentNode^.mLengthOfString + 1;
   currentNode^.mString[ currentNode^.mLengthOfString ] := c
  END;
  firstChar := FALSE
 UNTIL EOLN;

 headNode := firstNode;
 headIndex := 1;
 tailNode := currentNode;
 tailIndex := tailNode^.mLengthOfString;
 vowels := [ 'a', 'e', 'i', 'o', 'u' ];
 WHILE NOT fEnd DO BEGIN
  IF NOT ( fToLowercase( headNode^.mString[ headIndex ] ) IN vowels ) THEN
   pIncrementHeadIndex;
  IF NOT ( fToLowercase( tailNode^.mString[ tailIndex ] ) IN vowels ) THEN
   pDecrementTailIndex;
  IF NOT fEnd THEN
   IF ( fToLowercase( headNode^.mString[ headIndex ] ) IN vowels )
   AND ( fToLowercase( tailNode^.mString[ tailIndex ] ) IN vowels ) THEN BEGIN
    newHeadVowel := tailNode^.mString[ tailIndex ];
    IF fIsLowercase( headNode^.mString[ headIndex ] ) THEN
     newHeadVowel := fToLowercase( newHeadVowel )
    ELSE
     newHeadVowel := fToUppercase( newHeadVowel );
    newTailVowel := headNode^.mString[ headIndex ];
    IF fIsUppercase( tailNode^.mString[ tailIndex ] ) THEN
     newTailVowel := fToUppercase( newTailVowel )
    ELSE
     newTailVowel := fToLowercase( newTailVowel );
    headNode^.mString[ headIndex ] := newHeadVowel;
    tailNode^.mString[ tailIndex ] := newTailVowel;
    pIncrementHeadIndex;
    pDecrementTailIndex
   END
 END;

 WRITELN;
 WRITE( 'This program''s output: ' );
 currentNode := firstNode;
 REPEAT
  i := 1;
  WHILE i <= currentNode^.mLengthOfString DO BEGIN
   WRITE( currentNode^.mString[ i ] );
   i := i + 1
  END;
  currentNode := currentNode^.mNextNode
 UNTIL currentNode = NIL;
 WRITELN;

 RELEASE( originalHeapState )
END.

SetMode2.pas:

Spoiler: ShowHide

CP/M Plus 1.0:

Code: [Select]
PROCEDURE pChangeScreenMode;
BEGIN
END;

AmsDOS:

Code: [Select]
PROCEDURE pChangeScreenMode;
BEGIN
 RA := CHR( 2 );
 USER( #BC0E )
END;


OS.pas:

Spoiler: ShowHide

CP/M Plus 1.0:

Code: [Select]
FUNCTION fOSIsAMSDOS : BOOLEAN;
BEGIN
 fOSIsAMSDOS := FALSE
END;

FUNCTION fOSIsCPM : BOOLEAN;
BEGIN
 fOSIsCPM := TRUE
END;

AmsDOS:

Code: [Select]
FUNCTION fOSIsAMSDOS : BOOLEAN;
BEGIN
 fOSIsAMSDOS := TRUE
END;

FUNCTION fOSIsCPM : BOOLEAN;
BEGIN
 fOSIsCPM := FALSE
END;


Lowrcase.pas:

Spoiler: ShowHide

Code: [Select]
FUNCTION fIsLowercase( p : CHAR ) : BOOLEAN;
BEGIN
 fIsLowercase := p IN [ 'a'..'z' ]
END;

FUNCTION fToLowercase( p : CHAR ) : CHAR;
VAR
 i : INTEGER;
BEGIN
 IF p IN [ 'A'..'Z' ] THEN BEGIN
  i := ORD( p ) - ORD( 'A' );
  i := i + ORD( 'a' );
  p := CHR( i )
 END;
 fToLowercase := p
END;


Upprcase.pas:

Spoiler: ShowHide

Code: [Select]
FUNCTION fIsUppercase( p : CHAR ) : BOOLEAN;
BEGIN
 fIsUppercase := p IN [ 'A'..'Z' ]
END;

FUNCTION fToUppercase( p : CHAR ) : CHAR;
VAR
 i : INTEGER;
BEGIN
 IF p IN [ 'a'..'z' ] THEN BEGIN
  i := ORD( p ) - ORD( 'a' );
  i := i + ORD( 'A' );
  p := CHR( i )
 END;
 fToUppercase := p
END;

Offline SRS

  • Supporter
  • 6128 Plus
  • *
  • Posts: 649
  • Country: de
  • Schneider CPC464 - what else ?
  • Liked: 652
  • Likes Given: 379
Re: A little Pascal programming…
« Reply #7 on: 23:21, 05 March 20 »
I like to QUICKHACK ;)
Eat LOCOMOTIVE, Programming Praxis
Code: [Select]
10 REM Reverse Vowels by SRS 05.03.2020
20 MODE 2
30 PRINT "Please enter a string; this program will then reverse the vowels in that string,":PRINT "maintaining the original capitalisation of the vowels."
40 PRINT
50 INPUT"Your String:",s$
60 FOR i=LEN(s$) TO 1 STEP -1:c$=MID$(s$,i,1):IF INSTR("aeiouAEIOU",c$) THEN rv$=rv$+c$
70 NEXT
80 FOR i=1 TO LEN(s$):c$=MID$(s$,i,1):IF INSTR("aeiou",c$) THEN rs$=rs$+LOWER$(LEFT$(rv$,1)):rv$=RIGHT$(rv$,LEN(rv$)-1):GOTO 110
90 IF INSTR("AEIOU",c$) THEN rs$=rs$+UPPER$((LEFT$(rv$,1))):rv$=RIGHT$(rv$,LEN(rv$)-1):GOTO 110
100 rs$=rs$+c$
110 NEXT
120 PRINT "My Output: ";rs$

Offline the graveborn

  • CPC464
  • **
  • Posts: 18
  • Country: gb
    • the graveborn
  • Liked: 7
  • Likes Given: 10
Re: A little Pascal programming…
« Reply #8 on: 14:05, 18 June 21 »
The following is my solution to the "Fizzbuzz" problem posed by Programming Praxis, and is known to run on an emulated (using Arnold 1.7. 8) Amstrad CPC 6128 on both CP/M Plus 1.0 (my solution compiled using HiSoft Pascal for CP/M-80) and AMSDOS (my solution compiled using HiSoft Pascal Amstrad CPC464); as I often do when I try to solve problems posed by Project Euler, I began by programming a prototype of my solution in the slower-to-execute(than the programming languages I typically program in)but-faster-to-program-in Python programming language - on this occassion, because I (correctly, as it transpires) suspected that the output (233,168, as it transpires) for the maximum input (1,000) would exceed the maximum value (32,767) able to be stored in an INTEGER in HiSoft' - the Python programming language's built-in "big integers" are very helpful for that kind of prototyping.

(I'm just trying to solve the problems posed by the aforementioned 'site whilst I try to get a job (and I've solved this problem in particular to try to program an error-tolerant sub-routine for getting integers from the user, for potential future projects...); I'm well-aware that my solutions are far from the best - but, in my defense, I don't have any traditional qualifications in computer science :/ )

investigation.py:

Code: [Select]
def check_type_is_int( p ):
   if not isinstance( p, int ):
      s = str( type( p ))
      index_a = s.find( "'" )
      index_b = s.rfind( "'" )
      s = s[ index_a + 1 : index_b ]
      if s[ 0 ].lower() not in "aeiou":
         s = "a `" + s
      else:
         s = "an `" + s
      raise TypeError( "`p` is " + s + "`, not an `int`" )

def check_value_is_not_lower_than_minimum( value, minimum ):
   check_type_is_int( value )
   check_type_is_int( minimum )
   if value < minimum:
      raise ValueError( "`value` (" + str( value ) + ") < `minimum` (" + str( minimum ) + ')' )

def fizzbuzz_sequence( limit ):
   check_value_is_not_lower_than_minimum( limit, 1 )
   print "The fizzbuzz sequence for the range [ 1, " + str( limit ) + " ] is:"
   print
   for i in xrange( 1, limit + 1 ):
      s = '\t' + str( i ) + " - "
      fizz_or_buzz = False
      if i % 3 == 0:
         s = s + "Fizz"
         fizz_or_buzz = True
      if i % 5 == 0:
         s = s + "Buzz"
         fizz_or_buzz = True
      if not fizz_or_buzz:
         s = s + str( i )
      print s

def get_fizzbuzz_sum( limit ):
   check_value_is_not_lower_than_minimum( limit, 2 )
   result = 0
   for i in xrange( 1, limit ):
      if ( i % 3 == 0 ) or ( i % 5 == 0 ):
         result += i
   return result

def get_number_of_digits( p ):
   check_type_is_int( p )
   if p == 0:
      result = 1
   else:
      if p < 0:
         p *= -1
      result = 0
      while p > 0:
         p /= 10
         result += 1
   return result

def fizzbuzz_sum( limit ):
   result = get_fizzbuzz_sum( limit )
   print "The sum of all of the multiples of 3 or 5 below " + str( limit ) + " is " + str( result ) + '.'
   print
   result = get_number_of_digits( result )
   s1 = ""
   s2 = "is"
   if result != 1:
      s1 = 's'
      s2 = "are"
   print str( result ) + " digit" + s1 + ' ' + s2 + " needed to store the sum of the multiples of 3 or 5 below " + str( limit ) + '.'

print
fizzbuzz_sequence( 25 )
print
fizzbuzz_sum( 10 )
print
fizzbuzz_sum( 1000 )
print

PP210323.pas:

Code: [Select]
(* Programming Praxis *)
(* "Fizzbuzz" (23rd of March, 2021) *)

PROGRAM PP210323;

LABEL
 0;

CONST
 kRIFUDebug = FALSE;

 (*$F CONST   .PAS*)

TYPE

 (*$F TYPE    .PAS*)

VAR
 option : 0..2;
 errorOccurred, anythingRead : BOOLEAN;
 i : INTEGER;
 limit : 0..kLimit;

 (*$F TIMINGV .PAS*)

(*$F SETMODE2.PAS*)
(*$F OS      .PAS*)
(*$F RIFU    .PAS*)

PROCEDURE pReadNothingFromUser;
VAR
 c : CHAR;
BEGIN
 REPEAT
  READ( c )
 UNTIL EOLN
END;

(*$F SEQUENCE.PAS*)
(*$F TIMINGS .PAS*)
(*$F SUM     .PAS*)

BEGIN
 pChangeScreenMode;
 IF fOSIsCPM THEN
  WRITELN;
 0:option := 0;
 REPEAT
  WRITELN( 'Please enter whether you want to...' );
  WRITELN( ' 1. enumerate the fizzbuzz sequence' );
  WRITELN( ' 2. sum all of the multiples of 3 or 5' );
  WRITELN( '...below a given number, and press the Return key.' );
  WRITELN;
  WRITE( '(Or enter nothing and press the Return key to exit this program.)' );
  WRITELN;
  WRITELN;
  WRITE( 'Your input: ' );
  pReadIntegerFromUser( errorOccurred, anythingRead, i );
  IF anythingRead THEN BEGIN
   IF NOT errorOccurred THEN
    errorOccurred := ( i < 1 ) OR ( i > 2 );
   IF NOT errorOccurred THEN
    option := i
   ELSE BEGIN
    WRITELN;
    WRITELN( 'Sorry, an error occurred: your input was neither 1 nor 2.' );
    WRITELN;
    WRITE( 'Please press the Return key to try again.' );
    pReadNothingFromUser;
    WRITELN
   END
  END
 UNTIL NOT errorOccurred;

 IF option <> 0 THEN
  REPEAT
   WRITELN;
   WRITE( 'Please enter an integer in the range ( 1, 1000 ] and press the ' );
   WRITE( 'Return key; this program will then ' );
   CASE option OF
    1:WRITE( 'enumerate the fizzbuzz sequence' );
    2:WRITE( 'sum all of the multiples of 3 or 5' )
   END;
   WRITELN( ' below that integer.' );
   WRITELN;
   WRITE( '(Or enter nothing and press the Return key to return to the ' );
   WRITELN( 'previous option.)' );
   WRITELN;
   WRITE( 'Your input: ' );
   pReadIntegerFromUser( errorOccurred, anythingRead, i );
   IF anythingRead THEN BEGIN
     IF NOT errorOccurred THEN
      errorOccurred := ( i <= 1 ) OR ( i > 1000 );
     IF NOT errorOccurred THEN
      limit := i
     ELSE BEGIN
      WRITELN;
      WRITE( 'Sorry, an error occurred: your input was not an integer in ' );
      WRITELN( 'the range ( 1, ' );
      WRITELN( '1000 ].' );
      WRITELN;
      WRITE( 'Please press the Return key to try again.' );
      pReadNothingFromUser
     END
    END
   ELSE
    BEGIN
     WRITELN;
     GOTO 0
    END
  UNTIL NOT errorOccurred;

 IF option <> 0 THEN BEGIN
  WRITELN;
  CASE option OF
   1:pSequence( limit - 1 );
   2:BEGIN
    pStartTiming;
    pSum( limit );
    pStopTiming;
    IF fOSIsAMSDOS THEN BEGIN
     WRITELN;
     WRITE( 'To sum all of the multiples of 3 or 5 below ', limit:0, ' ' );
     WRITE( 'took ', fSeconds:0, ' second' );
     IF fSeconds <> 1 THEN
      WRITE( 's' );
     WRITELN( '.' )
    END
   END
  END
 END
END.

const.pas:

Code: [Select]
kLimit = 1000;
kLimitPlusOne = 1001;

type.pas:

Code: [Select]
tLimit = 1..kLimit;
tLimitPlusOne = 1..kLimitPlusOne;

RIFU.pas:

Code: [Select]
PROCEDURE pReadIntegerFromUser( VAR pErrorOccurred, pAnythingRead : BOOLEAN;
                                VAR pInteger : INTEGER );
TYPE
 tDigit = 0..9;
 tCharSet = SET OF CHAR;
VAR
 digits : ARRAY [ 1..5 ] OF tDigit;
 sign : CHAR;

 PROCEDURE pLeftShiftArrayOfDigits;
 VAR
  i : 1..5;
 BEGIN
  FOR i := 5 DOWNTO 2 DO
   digits[ i ] := digits[ i - 1 ];
  digits[ 1 ] := 0
 END;

 FUNCTION fOutOfRange( pSign : tCharSet; pDigitAtIndex1 : tDigit ) : BOOLEAN;
 LABEL
  0;
 VAR
  result : BOOLEAN;
  range : ARRAY [ 1..5 ] OF tDigit;
  i : 0..5;
 BEGIN
  result := FALSE;
  IF sign IN pSign THEN BEGIN
   range[ 5 ] := 3;
   range[ 4 ] := 2;
   range[ 3 ] := 7;
   range[ 2 ] := 6;
   range[ 1 ] := pDigitAtIndex1;
   FOR i := 5 DOWNTO 1 DO
    IF digits[ i ] < range[ i ] THEN
     GOTO 0
    ELSE
     IF digits[ i ] > range[ i ] THEN BEGIN
      result := TRUE;
      GOTO 0
     END
  END;
  0:fOutOfRange := result
 END;

 FUNCTION fTooLow : BOOLEAN;
 BEGIN
  fTooLow := fOutOfRange( [ '-' ], 8 )
 END;

 FUNCTION fTooHigh : BOOLEAN;
 BEGIN
  fTooHigh := fOutOfRange( [ ' ', '+' ], 7 )
 END;

 FUNCTION fArrayOfDigitsToInteger : INTEGER;
 VAR
  result : INTEGER;
  multiplier : 1..10000;
  i : 1..6;
  intermediate : INTEGER;
 BEGIN
  result := 0;
  multiplier := 1;
  FOR i := 1 TO 5 DO BEGIN
   IF i <> 1 THEN
    multiplier := multiplier * 10;
   intermediate := digits[ i ] * multiplier;
   IF sign = '-' THEN
    intermediate := intermediate * ( -1 );
   result := result + intermediate
  END;
  fArrayOfDigitsToInteger := result
 END;

 PROCEDURE pInner;
 LABEL
  0, 1;
 VAR
  c : CHAR;
  validChar, anyDigitEncountered : BOOLEAN;
  numberOfDigits : 0..5;
  i : 1..6;
  endOfLine, firstChar, blankLineWritten : BOOLEAN;

  FUNCTION fSign : BOOLEAN;
  VAR
   result : BOOLEAN;
  BEGIN
   result := TRUE;
   IF c IN [ '+', '-' ] THEN BEGIN
    validChar := TRUE;
    IF sign <> ' ' THEN BEGIN
      result := FALSE;
      IF kRIFUDebug THEN
       WRITELN( 'fSign - sign <> '' ''' )
     END
    ELSE
     IF anyDigitEncountered THEN BEGIN
       result := FALSE;
       IF kRIFUDebug THEN
        WRITELN( 'fSign - anyDigitEncountered = TRUE' )
      END
     ELSE
      sign := c
   END;
   fSign := result
  END;

  FUNCTION fDigit0 : BOOLEAN;
  VAR
   result : BOOLEAN;
  BEGIN
   result := TRUE;
   IF c = '0' THEN BEGIN
    validChar := TRUE;
    anyDigitEncountered := TRUE;
    IF numberOfDigits > 0 THEN
     IF numberOfDigits = 5 THEN BEGIN
       result := FALSE;
       IF kRIFUDebug THEN
        WRITELN( 'fDigit0 - numberOfDigits > 5' )
      END
     ELSE
      BEGIN
       pLeftShiftArrayOfDigits;
       digits[ 1 ] := 0;
       numberOfDigits := numberOfDigits + 1
      END
   END;
   fDigit0 := result
  END;

  FUNCTION fDigits1To9 : BOOLEAN;
  VAR
   result : BOOLEAN;
  BEGIN
   result := TRUE;
   IF c IN [ '1'..'9' ] THEN BEGIN
    validChar := TRUE;
    anyDigitEncountered := TRUE;
    IF numberOfDigits = 5 THEN BEGIN
      result := FALSE;
      IF kRIFUDebug THEN
       WRITELN( 'fDigits1To9 - numberOfDigits > 5' )
     END
    ELSE
     BEGIN
      IF numberOfDigits > 0 THEN
       pLeftShiftArrayOfDigits;
      digits[ 1 ] := ORD( c ) - ORD( '0' );
      numberOfDigits := numberOfDigits + 1
     END
   END;
   fDigits1To9 := result
  END;

 BEGIN
  pErrorOccurred := FALSE;
  pAnythingRead := FALSE;
  FOR i := 1 TO 5 DO
   digits[ i ] := 0;
  sign := ' ';
  anyDigitEncountered := FALSE;
  numberOfDigits := 0;
  firstChar := TRUE;
  blankLineWritten := FALSE;

  REPEAT
   READ( c );
   endOfLine := EOLN;
   IF NOT firstChar THEN BEGIN
    pAnythingRead := TRUE;
    IF kRIFUDebug THEN BEGIN
     IF NOT blankLineWritten THEN BEGIN
      WRITELN;
      blankLineWritten := TRUE
     END;
     WRITELN( 'pInner - c = ''', c, '''' )
    END;
    validChar := FALSE;
    IF NOT fSign THEN
     GOTO 0;
    IF NOT fDigit0 THEN
     GOTO 0;
    IF NOT fDigits1To9 THEN
     GOTO 0;
    IF NOT validChar THEN BEGIN
     IF kRIFUDebug THEN
      WRITELN( 'pInner - validChar = FALSE' );
     GOTO 0
    END
   END;
   firstChar := FALSE
  UNTIL endOfLine;

  IF pAnythingRead AND NOT anyDigitEncountered THEN BEGIN
   IF kRIFUDebug THEN
    WRITELN( 'pInner - pAnythingRead = TRUE AND anyDigitEncountered = FALSE' );
   GOTO 0
  END;
  IF fTooLow THEN BEGIN
   IF kRIFUDebug THEN
    WRITELN( 'pInner - fTooLow = TRUE' );
   GOTO 0
  END;
  IF fTooHigh THEN BEGIN
   IF kRIFUDebug THEN
    WRITELN( 'pInner - fTooHigh = TRUE' );
   GOTO 0
  END;
  GOTO 1;
  0:pErrorOccurred := TRUE;
  IF NOT endOfLine THEN
   REPEAT
    READ( c );
    IF kRIFUDebug THEN
     WRITELN( 'pInner - (discarding) c = ''', c, '''' )
   UNTIL EOLN;
  1:IF NOT pErrorOccurred THEN
   pInteger := fArrayOfDigitsToInteger
 END;

BEGIN
 pInner
END;

Sequence.pas:

Code: [Select]
PROCEDURE pSequence( limit : tLimit );
VAR
 i : tLimitPlusOne;
 fizzOrBuzz : BOOLEAN;
BEGIN
 WRITE( 'The fizzbuzz sequence for the range [ 1, ', limit:0, ' ] is: ' );
 FOR i := 1 TO limit DO BEGIN
  IF i > 1 THEN
   WRITE( ', ' );
  fizzOrBuzz := FALSE;
  IF i MOD 3 = 0 THEN BEGIN
   WRITE( 'Fizz' );
   fizzOrBuzz := TRUE
  END;
  IF i MOD 5 = 0 THEN BEGIN
   WRITE( 'Buzz' );
   fizzOrBuzz := TRUE
  END;
  IF NOT fizzOrBuzz THEN
   WRITE( i:0 )
 END;
 WRITELN( '.' )
END;

TimingV.pas (CP/M):



TimingV.pas (AMSDOS):

Code: [Select]
seconds : 0..MAXINT;
TimingS.pas (CP/M):

Code: [Select]
PROCEDURE pStartTiming;
BEGIN
END;

FUNCTION fSeconds : INTEGER;
BEGIN
 fSeconds := -1
END;

PROCEDURE pStopTiming;
BEGIN
END;

TimingS.pas (AMSDOS):

Code: [Select]
PROCEDURE pTimedMessage;
VAR
 ignored : INTEGER;
BEGIN
 WRITELN( 'Please wait...' );
 WRITELN;
 ignored := REMAIN( 2 )
END;

PROCEDURE pIncrementSeconds;
BEGIN
 seconds := seconds + 1
END;

PROCEDURE pStartTiming;
BEGIN
 AFTER( 5 * 50, 2, pTimedMessage );
 seconds := 0;
 EVERY( 50, 3, pIncrementSeconds )
END;

FUNCTION fSeconds : INTEGER;
BEGIN
 fSeconds := seconds
END;

PROCEDURE pStopTiming;
VAR
 ignored : INTEGER;
BEGIN
 ignored := REMAIN( 2 );
 ignored := REMAIN( 3 )
END;

Sum.pas:

Code: [Select]
PROCEDURE pSum( limit : tLimit );

CONST
 kMaximumIndex = 6;

TYPE
 tZeroOrPositiveInteger = 0..MAXINT;
 tIndex = 1..6;

VAR
 digits : ARRAY [ 1..6 ] OF 0..18;
 i : 1..7;
 k : tLimit;
 digitWritten : BOOLEAN;

PROCEDURE (* Increase *) pOuter( p : tZeroOrPositiveInteger );
VAR
 index : 0..kMaximumIndex;
 digit : 0..9;

PROCEDURE (* Increase *) pInner( p : tIndex );
BEGIN
 IF digits[ p ] >= 10 THEN BEGIN
  digits[ p ] := digits[ p ] MOD 10;
  digits[ p - 1 ] := digits[ p - 1 ] + 1;
  pInner( p - 1 )
 END
END;

BEGIN
 index := kMaximumIndex;
 WHILE p > 0 DO BEGIN
  digit := p MOD 10;
  p := p DIV 10;
  digits[ index ] := digits[ index ] + digit;
  pInner( index );
  index := index - 1
 END
END;

BEGIN
 FOR i := 1 TO kMaximumIndex DO
  digits[ i ] := 0;
 FOR k := 1 TO limit - 1 DO
  IF ( k MOD 3 = 0 ) OR ( k MOD 5 = 0 ) THEN
   pOuter( k );
 WRITE( 'The sum of all of the multiples of 3 or 5 below ', limit:0, ' is ' );
 digitWritten := FALSE;
 FOR i := 1 TO kMaximumIndex - 1 DO
  IF ( digits[ i ] <> 0 ) OR digitWritten THEN BEGIN
   WRITE( digits[ i ]:0 );
   digitWritten := TRUE
  END;
 WRITELN( digits[ kMaximumIndex ]:0, '.' )
END;