Hisoft Pascal 4T

[ralferoo]

So the idea I had was if you took the largest Integer based number which is 32767 in this case, divide it by a range specified, it will work out how many times how many times that will go into 32767 to which that gets stored into result. The next part is getting a random number, which I've done by storing a random number into seed, the seed is then divided with the result to produce a number within the specified range specified. In my example line 160 uses the function which specifies a range between 0-30 and the output from line 170 will certainly correspond to that.

This will produce skewed distributions, and also wrong results in some cases, even in your example case.

Consider a range of 30000. Result will be 1, so integers will be returned 0..32767.
Consider a range of 20000. Result will be 2, so integers will be returned 0..16383.
Consider a range of 30. Result will be 1092, so integers will be returned 0..30 (0..29 will be returned with p=1092/32768, 30 will be returned with p=7/32768).

There's a much better way of doing it, although I'm not sure how easy it is to achieve in pascal. But it's essentially based on the original random number being evenly distributed over 0..32767 (i.e. 0..2^15-1)

So, in C, it'd be:

Code: [Select]

uint16_t randrange(uint16_t range)
{
 uint16_t seed = random(0);
uint32_t scale = seed * range;
uint16_t result = (uint16_t) (scale>>15);
return result;
}
This has the advantage that you've only got a shift and a multiply instead of 2 divides.

The shift right by 15 is also effectively a shift left by 2 and discarding the lower bytes. In assembler, say for example DE:HL holds the 32 bit number, that's just:

Code: [Select]

ADD HL,HL
EX DE,HL
ADC HL,HL
leaving the result in HL. So, it's just the multiply that needs to be done, but hopefully there's something in the pascal library to do that for you...

[AMSDOS]

Thanks for picking that up, unfortunately the code I posted earlier went through a series of changes, before I realised I had some other problems which wasn't giving me the correct results and as you picked up larger numbers are getting through or are limited in nature.


So I don't know if this following will meet with your approval, these old 8bit Pascal compilers don't have the luxury of long integers, true they do support "reals" which are larger again, though I think their main function is to be used as Decimal Based numbers:

Code: [Select]

   10 PROGRAM integernd;
   20
   30 VAR num1, loop : integer;
   40
   50 FUNCTION intrnd(range : integer) : integer;
   60 VAR seed   : integer;
   70     result : real;
   80 BEGIN
   90   seed:=random(0);
  100   result:=(maxint/range);
  110   result:=(seed/result);
  120   intrnd:=round(result);
  130 END;
  140
  150 BEGIN
  160   FOR loop:=0 TO 100 DO
  170   BEGIN
  180    num1:=intrnd(30000);
  190    write(num1);
  200   END;
  210 END.


So in this case I've reverted result as a real type because I really need the decimal accuracy to determine the true range, I guess if it's bad to Divide twice I could alter these lines:

Code: [Select]


  100   result:=(range/maxint);
  110   result:=(seed*result);


With line 120, I found if my range was 1, I was just getting 0's, so rounding the number up at that stage should be fine. I'll have to try some more numbers, though I haven't noticed any larger numbers out of their range. Unfortunately I'm unsure on how to do an alternative using Pascal, though I can certainly check out Assembly alternatives which I have already done with the 8bit random number generator. I was trying to do something like this just to see if I could apply some kind of range process in the same manner as BASIC returning a random number in range by using something like this:

Code: [Select]

? rnd*15

[AMSDOS]

I've had a go at converting this BASIC Star Field program, so it works to a point in Hisoft Pascal. I say to a point because I've been comparing the two programs, my Hisoft Pascal programs works and execution timing makes it interesting to compare with the Original program.   
Though in my program, the stars seem to wobble around, which I quite like, though the original program doesn't really show any wobbling stars moving around the screen, because BASIC has this ingenious way of taking Decimal based numbers and get it to work with Integer based numbers (and in this case there's also Arrays).

[AMSDOS]

Another one I've got on my Turbo Pascal website, to get it running in Hisoft Pascal 4T, some behind the scenes coding was required to get this one working, which relates to setting up a character matrix and pointing it to the address of the array where I wanted to put my redefined character.

[AMSDOS]

So, in C, it'd be:

Code: [Select]

uint16_t randrange(uint16_t range)
{
 uint16_t seed = random(0);
uint32_t scale = seed * range;
uint16_t result = (uint16_t) (scale>>15);
return result;
}
This has the advantage that you've only got a shift and a multiply instead of 2 divides.

The shift right by 15 is also effectively a shift left by 2 and discarding the lower bytes.

Ok, I think I understand your example now after playing around with the Shift Instructions.    So what I did was say my seed is 32767 and I want a range of 200, using my Base-N Calculator (in Decimal), I get a value of 6553400, so if I divide that value by 2 15 times (which is a shift Right), my result is 199. Nice. 

[AMSDOS]

Working from the BASIC routine I made to plot a series of points onscreen from this thread, I can easily reconstruct that routine to work in Hisoft Pascal and take advantage of the speed.


[attachimg=2]

[AMSDOS]

Finally got around to making a little rotating square demonstration, the following program is very involved and I setup up a data file for the square data, which I made using a modified SaveData program which I posted earlier. The Data Array consists of all the start positions for each square (6 in all), followed by the points. With all that data in the data array, I've setup 2 more arrays which holds the data for the X & Y information. Once all that information is in place I can use the Loop Procedure to draw those squares,  "num1" deals with the position of the array and "col" for the graphics colour.

In addition to the rotating squares, I'm using the every time routine to execute a little border routine, initially I wanted it to count through the different border colours (0-26), though I wasn't allowed to pass variable data though the every event, so is randomly selecting colours as everything moves through.

Code: [Select]

   10 PROGRAM movsquare;
   20 {$C-}
   30
   40 VAR
   50   data : ARRAY[0..59] OF integer;
   60   xdta : ARRAY[0..29] OF integer;
   70   ydta : ARRAY[0..29] OF integer;
   80   count, num, num2, value : integer;
   90   col : integer;
  100   ch1 : char;
  110
  120 PROCEDURE setup;
  130  BEGIN
  140    tin('square  .dat',addr(data));
  150    FOR count:=0 TO 29 DO
  160      xdta[count]:=data[count];
  170    num:=30;
  180    FOR count:=0 TO 29 DO
  190      BEGIN
  200        ydta[count]:=data[num];
  210        num:=num+1;
  220      END;
  230  END; { Setup }
  240
  250 PROCEDURE move(x,y : integer);
  260 BEGIN
  270   rde:=x; rhl:=y;
  280   user(#bbc0);
  290 END;
  300
  310 PROCEDURE mode(no : integer);
  320 BEGIN
  330  ra:=chr(no);
  340  user(#bc0e);
  350 END;
  360
  370 PROCEDURE border(col : integer);
  380 BEGIN
  390   rb:=chr(col); rc:=chr(col);
  400   user(#bc38);
  410 END;
  420
  430 PROCEDURE drawr(x,y : integer);
  440 BEGIN
  450   rde:=x; rhl:=y;
  460   user(#bbf9);
  470 END;
  480
  490 FUNCTION rdkey : char;
  500 BEGIN
  510  user(#bb1b);
  520  rdkey:=ra;
  530 END;
  540
  550 PROCEDURE kmreset;
  560 BEGIN
  570  user(#bb03);
  580 END;
  590
  600 PROCEDURE grapen(no : integer);
  610 BEGIN
  620   ra:=chr(no);
  630   user(#bbde);
  640 END;
  650
  660 PROCEDURE loop(num1, col : integer);
  670 VAR num : integer;
  680 BEGIN
  690   num:=num1;
  700   grapen(col);
  710   move(xdta[num],ydta[num]);
  720   num:=num+1;
  730   drawr(xdta[num],ydta[num]);
  740   num:=num+1;
  750   drawr(xdta[num],ydta[num]);
  760   num:=num+1;
  770   drawr(xdta[num],ydta[num]);
  780   num:=num+1;
  790   drawr(xdta[num],ydta[num]);
  800 END;
  810
  820 FUNCTION intrnd(range : integer) : integer;
  830 VAR seed : integer;
  840     result : real;
  850 BEGIN
  860   seed:=random(0);
  870   result:=(range/maxint);
  880   result:=(seed*result);
  890   intrnd:=trunc(result);
  900 END;
  910
  920 PROCEDURE bordloop;
  930 VAR num : integer;
  940 BEGIN
  950   num:=intrnd(26);
  960   border(num);
  970 END;
  980
  990 PROCEDURE frame;
 1000 BEGIN
 1010  user(#bd19);
 1020 END;
 1030
 1040 BEGIN { Main }
 1050  kmreset;
 1060  setup;
 1070  mode(0);
 1080   every(10,1,bordloop);
 1090  num:=0;
 1100  REPEAT
 1110    col:=col+1;
 1120    IF col=27 THEN col:=0;
 1130    loop(num,1);
 1140    frame; frame;
 1150    num2:=num;
 1160    num:=num+5;
 1170    IF num2=30 THEN num2:=0;
 1180    IF num=30 THEN num:=0;
 1190    loop(num2,0);
 1200    ch1:=rdkey;
 1210    value:=ord(ch1);
 1220  UNTIL value=252;
 1230  mode(2);
 1240 END. { Main }


[AMSDOS]

This little interesting Graphics Demonstration originally published in AA makes good use of decimal numbers in incrementing colour change & the curvature, I thought it would be interesting to compare the results in Pascal with the original BASIC program. The results look good when compared to the original, though in Pascal when it deals with Decimal numbers, they have to be converted into Integers otherwise Errors result if trying to pass a Decimal number to an Integer Type.


So a relatively small BASIC program (10 Lines or so), becomes a Lengthy Pascal program and the produced Binary is 8Kb, most of that is Library though due to the Compiler of it's day (1984). 

Code: [Select]

   10 PROGRAM Graphics;
   20 {$C-}
   30
   40 VAR mnloop, loop : integer;
   50     x, xa, y, ya : real;
   60     xx, yy, c    : real;
   70     a, b         : integer;
   80     ch           : char; 
   90
  100 PROCEDURE mode(no : integer);
  110 BEGIN
  120   ra:=chr(no);
  130   user(#bc0e);
  140 END;
  150
  160 PROCEDURE ink(ink, col1 : integer);
  170 BEGIN
  180   ra:=chr(ink);
  190   rb:=chr(col1);
  200   rc:=chr(col1);
  210   user(#bc32);
  220 END;
  230
  240 PROCEDURE border(col : integer);
  250 BEGIN
  260   rb:=chr(col);
  270   rc:=chr(col);
  280   user(#bc38);
  290 END;
  300
  310 PROCEDURE plot(x,y : integer);
  320 BEGIN
  330   rde:=x;
  340   rhl:=y;
  350   user(#bbea);
  360 END;
  370
  380 PROCEDURE grapen(col : integer);
  390 BEGIN
  400   ra:=chr(col);
  410   user(#bbde);
  420 END;
  430
  440 PROCEDURE move(x,y : integer);
  450 BEGIN
  460   rde:=x;
  470   rhl:=y;
  480   user(#bbc0);
  490 END;
  500
  510 PROCEDURE draw(x,y : integer);
  520 BEGIN
  530   rde:=x;
  540   rhl:=y;
  550   user(#bbf6);
  560 END;
  570
  580 FUNCTION rdkey : char;
  590 BEGIN
  600   user(#bb1b);
  610   rdkey:=ra;
  620 END;
  630
  640 BEGIN
  650   mode(0);
  660   border(0);
  670   ink(0,0);
  680   FOR loop:=1 TO 15 DO
  690     ink(loop,loop+11);
  700   grapen(1);
  710   c:=1;
  720   a:=160;
  730   b:=100;
  740   x:=1;
  750   y:=1;
  760   xx:=0;
  770   yy:=0;
  780   move(round(x),round(y));
  790   REPEAT
  800    xa:=x; ya:=y;
  810    IF x<a THEN xx:=xx+0.025
  820     ELSE IF x>a THEN xx:=xx-0.025;
  830    IF y<b THEN yy:=yy+0.025
  840     ELSE IF y>b THEN yy:=yy-0.025;
  850    x:=x+xx; y:=y+yy;
  860    grapen(round(c));
  870    plot(round(xa),1);
  880    draw(round(x),round(y));
  890    plot(640-round(xa),1);
  900    draw(640-round(x),round(y));
  910    plot(round(xa),400);
  920    draw(round(x),400-round(y));
  930    plot(640-round(xa),400);
  940    draw(640-round(x),400-round(y));
  950    c:=c+0.0625;
  960    IF c=15.5 THEN c:=1;
  970   ch:=rdkey;
  980   mnloop:=ord(ch);
  990   UNTIL mnloop=252;
 1000  ink(1,26);
 1010  mode(2);
 1020 END.

[attachimg=2]

[Gryzor]

Hey, much faster than BASIC!

[AMSDOS]

Hey, much faster than BASIC!

It's great when they can easily be translated from one language to another relatively easy.


This innocent little program in this thread is anything but and is a nightmare. This didn't seem to be a problem in the Graphic program above, but that Serpent program is somehow skewing results (though not at first), but the longer the program runs, the more lines appear onscreen, the difference appears to be "round(num)". Both BASIC & Pascal have it, but in Pascal if a number is negative and lands on a value .5, the number gets rounded down, so a value of -6.5 becomes -6, however if it was -6.51 Pascal rounds it to -7. In BASIC a value of -6.5 is rounded to -7 and I think it is there where Pascal is missing the drawn Lines. Positive Numbers seem to work the same in BASIC & Pascal and the program works mostly with the Negative as long as it doesn't fall on .5 of a number itself. Though I'm unsure fully if that is whats happening, but I don't know what else it could be.
The solution to that is start collecting values from the BASIC program and put it into an Array for the Pascal Program to lookup, though I'm unsure how big it might be.

[AMSDOS]

This is the workaround I have come up with the Serpent program.

Code: [Select]

   10 PROGRAM Serpent;
   20 {$C-}
   30
   40 VAR mnloop, loop : integer;
   50     num, num2    : integer;
   60     a            : real;
   70     ch           : char; 
   80     x1val : ARRAY[0..20] OF integer;
   90     x2val : ARRAY[0..20] OF integer;
  100     y1val : ARRAY[0..20] OF integer;
  110     y2val : ARRAY[0..20] OF integer;
  120
  130 PROCEDURE mode(no : integer);
  140 BEGIN
  150   ra:=chr(no);
  160   user(#bc0e);
  170 END;
  180
  190 PROCEDURE grapen(ink:integer);
  200 BEGIN
  210   ra:=chr(ink);
  220   user(#bbde)
  230 END;
  240
  250 PROCEDURE origin(x,y : integer);
  260 BEGIN
  270   rde:=x;
  280   rhl:=y;
  290   user(#bbc9);
  300 END;
  310 
  320 PROCEDURE move(x,y : integer);
  330 BEGIN
  340   rde:=x;
  350   rhl:=y;
  360   user(#bbc0);
  370 END;
  380
  390 PROCEDURE draw(x,y : integer);
  400 BEGIN
  410   rde:=x;
  420   rhl:=y;
  430   user(#bbf6);
  440 END;
  450
  460 PROCEDURE scraccess(mo : integer);
  470 BEGIN
  480   ra:=chr(mo);
  490   user(#bc59);
  500 END;
  510
  520 FUNCTION rdkey : char;
  530
  540 BEGIN
  550   user(#bb1b);
  560   rdkey:=ra;
  570 END;
  580
  590 PROCEDURE drawroutine(value : integer);
  600 BEGIN
  610   move(x1val[value],y1val[value]);
  620   grapen(1);
  630   draw(x2val[value],y2val[value]);
  640 END;
  650
  660 PROCEDURE removeline;
  670 BEGIN
  680   IF num2>20 THEN num2:=0;
  690   drawroutine(num2);
  700   num2:=num2+1;
  710 END;
  720
  730 BEGIN
  740   mode(1);
  750   origin(320,200);
  760   scraccess(1);
  770   a:=0.0;
  780   num:=0; num2:=0;
  790   REPEAT
  800   x1val[num]:=round(220*sin(a/2));
  810   y1val[num]:=round(98*cos(a));
  820   x2val[num]:=round(200*cos(a/2));
  830   y2val[num]:=round(198*sin(a));
  840   drawroutine(num);
  850   a:=a-2.0;
  860   IF a>-0.1 THEN removeline;
  870   num:=num+1;
  880   IF num>20 THEN num:=0;
  890   a:=a+2.1;
  900   ch:=rdkey;
  910   mnloop:=ord(ch);
  920   UNTIL mnloop=252;
  930  mode(2);
  940 END.

It still does the maths, but I'm storing the values into 4 Arrays and use num & num2 variables to offset the effect.


[attachimg=2]

[AMSDOS]

I've come up with another graphical demo by Laurence Rapaccioli (from the ACU 10-Liner Days) of an Alien Landscape and reworked it so it would work in Hisoft Pascal, but as you will see the program blew out over 200 Lines of Code, but on top of that code is a RSX Library I've generated to deal with a lot of the graphical aspects from the program along with a FILL routine, so this program now works on all CPCs.


Much of the original program made good use of DEG & RAD which is where a lot of the Pascal has blown out, though a lot of "FOR" Loops were also involved in the original program which were replaced with WHILE...DO loops in order to control the STEPs for the value of the Loop and probably the other blow out was replacing GOTOs and relying on more Procedural Structure, but the good news is the reworked has the same feel as the original where by once the Landscape is completely drawn, Press <Space> to see a Shooting Meteorite across the Horizon. 


I'm just surprised how involved it became, the coding of it could probably be improved, the Generated Binary takes up 11k, probably around 12k with the RSX, which required some overhead in this main program in order to utilise.

Code: [Select]

   10 PROGRAM Alien;
   20 {$C-}
   30
   40 VAR loopa, loopn, loopm : integer;
   50     b, c, d, f, g, h, i : integer;
   60     ch1 : char;
   70     value : integer;
   80     routine : ARRAY[0..475] OF char;
   90
  100 FUNCTION rnd(range : integer) : integer;
  110 VAR seed : integer;
  120     result : real;
  130 BEGIN
  140   seed:=random(0);
  150   result:=(range/maxint);
  160   result:=(seed*result);
  170   rnd:=trunc(result);
  180 END;
  190
  200 FUNCTION deg(val : integer) : real;
  210 VAR num1 : real;
  220 BEGIN
  230   num1:=3.14159/180;
  240   deg:=num1*val;
  250 END;
  260
  270 FUNCTION rdkey : char;
  280 BEGIN
  290   user(#bb1b);
  300   rdkey:=ra;
  310 END;
  320
  330 FUNCTION test(x,y : integer) : integer;
  340 BEGIN
  350   rde:=x; rhl:=y;
  360   user(#bbf0);
  370   test:=ord(ra);
  380 END;
  390
  400 PROCEDURE kmreset;
  410 BEGIN
  420   user(#bb03);
  430 END;
  440
  450
  460 PROCEDURE setupgralib;
  470  VAR loop : integer;
  480  BEGIN
  490    tin('gralib  .dat',addr(routine));
  500    FOR loop:=0 TO 475 DO
  510      poke(#9000+loop,routine[loop]);
  520    user(#9000);
  530 END;
  540
  550 PROCEDURE setup;
  560 BEGIN
  570   external('mode',1);
  580   external('ink',0,0);
  590   external('ink',1,5);
  600   external('ink',2,22);
  610   external('ink',3,15);
  620 END;
  630
  640 PROCEDURE screen;
  650 VAR x1, y1 : integer;
  660     x2, y2 : integer;
  670 BEGIN
  680 b:=300; c:=40; d:=15;
  690 FOR loopn:=0 TO 6 DO
  700  BEGIN
  710    external('grapen',1);
  720    external('plot',320+b+100,200);
  730    loopa:=0;
  740    WHILE (loopa<370) DO BEGIN
  750      x1:=round(320+(b+100)*cos(deg(loopa)));
  760      y1:=round(200+b*sin(deg(loopa)));
  770      external('draw',x1,y1);
  780      x2:=round(c*sin(deg(loopa)));
  790      y2:=round(d*cos(deg(loopa)));
  800      external('drawr',x2,y2);
  810      IF c=40 THEN c:=-41 ELSE c:=40;
  820      IF d<>15 THEN d:=-16 ELSE d:=15;
  830      IF d=15 THEN d:=-16 ELSE d:=15;
  840      loopa:=loopa+10;
  850    END;
  860    b:=b-20;
  870  END;
  880 external('grapen',1); external('plot',40,202); external('draw',600,202);
  890 external('fill',272,200,3); external('fill',44,184,3);
  900 external('fill',76,124,3); external('fill',140,72,3);
  910 external('fill',220,36,3);
  920 loopn:=200;
  930 WHILE (loopn>15) DO BEGIN
  940   loopm:=40;
  950   WHILE (loopm<600) DO BEGIN
  960    IF test(loopm,loopn)=3 THEN BEGIN
  970     external('draw',loopm+rnd(6),loopn+rnd(12));
  980     external('draw',loopm+5,loopn);
  990     END;
 1000     loopm:=loopm+rnd(7)+7;
 1010    END;
 1020   loopn:=loopn-5;
 1030 END;
 1040 END;
 1050
 1060 PROCEDURE degdraw;
 1070 BEGIN
 1080   loopn:=1;
 1090   WHILE (loopn<360) DO BEGIN
 1100     external('grapen',f);
 1110     external('move',round(g+i*sin(deg(340))),round(h+i*cos(deg(loopn))));
 1120     external('draw',round(g+i*sin(deg(loopn))),round(h+i*cos(deg(200))));
 1130     loopn:=loopn+7;
 1140   END;
 1150 END;
 1160
 1170 PROCEDURE radraw;
 1180 BEGIN
 1190   loopn:=1;
 1200   WHILE (loopn<360) DO BEGIN
 1210     external('grapen',f);
 1220     external('move',round(g+i*sin(340)),round(h+i*cos(loopn)));
 1230     external('draw',round(g+i*sin(loopn)),round(h+i*cos(200)));
 1240     loopn:=loopn+7;
 1250   END;
 1260 END;
 1270
 1280 PROCEDURE scenery;
 1290 BEGIN
 1300   f:=1; g:=385; h:=226; i:=25;
 1310   degdraw;
 1320   f:=2; g:=350; h:=252; i:=50;
 1330   degdraw;
 1340   f:=2; g:=300; h:=222; i:=20;
 1350   degdraw;
 1360   f:=1; g:=200; h:=242; i:=40;
 1370   radraw;
 1380   f:=2; g:=130; h:=226; i:=25;
 1390   radraw;
 1400 END;
 1410
 1420 PROCEDURE planets;
 1430 VAR x1, x2, y1, y2 : integer;
 1440 BEGIN
 1450   loopa:=90;
 1460   WHILE (loopa<450) DO BEGIN
 1470     external('grapen',1); external('plot',505,300);
 1480     x1:=round(505+10*cos(deg(loopa)));
 1490     y1:=round(300+10*sin(deg(loopa)));
 1500     external('draw',x1,y1);
 1510     x2:=round(485+20*cos(deg(loopa)));
 1520     y2:=round(300+20*sin(deg(loopa)));
 1530     external('grapen',3); external('plot',485,300);
 1540     external('draw',x2,y2);
 1550     loopa:=loopa+3;
 1560   END;
 1570 END;
 1580
 1590 PROCEDURE drmeteor;
 1600 VAR x1, y1 : integer;
 1610 BEGIN
 1620   x1:=round(300+220*cos(deg(loopn)));
 1630   y1:=round(200+120*sin(deg(loopn)));
 1640   external('grapen',2);
 1650   external('plot',x1,y1);
 1660   x1:=round(300+220*cos(deg(loopn+3)));
 1670   y1:=round(200+120*sin(deg(loopn+3)));
 1680   external('draw',x1,y1);
 1690   x1:=round(300+220*cos(deg(loopn+3)));
 1700   y1:=round(200+120*sin(deg(loopn)));
 1710   external('draw',x1,y1);
 1720   x1:=round(300+220*cos(deg(loopn)));
 1730   y1:=round(200+120*sin(deg(loopn+3)));
 1740   external('draw',x1,y1);
 1750 END;
 1760
 1770 PROCEDURE delmeteor;
 1780 VAR x1,y1 : integer;
 1790 BEGIN
 1800   external('grapen',0);
 1810   x1:=round(300+220*cos(deg(loopn-20)));
 1820   y1:=round(200+120*sin(deg(loopn-20)));
 1830   external('plot',x1,y1);
 1840   x1:=round(300+220*cos(deg(loopn-17)));
 1850   y1:=round(200+120*sin(deg(loopn-17)));
 1860   external('draw',x1,y1);
 1870   x1:=round(300+220*cos(deg(loopn-17)));
 1880   y1:=round(200+120*sin(deg(loopn-20)));
 1890   external('draw',x1,y1);
 1900   x1:=round(300+220*cos(deg(loopn-20)));
 1910   y1:=round(200+120*sin(deg(loopn-17)));
 1920   external('draw',x1,y1);
 1930 END;
 1940
 1950 PROCEDURE launch;
 1960 BEGIN
 1970   loopn:=0;
 1980   WHILE (loopn<198) DO BEGIN
 1990     IF loopn<168 THEN drmeteor;
 2000     IF loopn>19 THEN delmeteor;
 2010     sound(3,0,0,round(loopn/25),round(loopn/15),3,30);
 2020     loopn:=loopn+4;
 2030   END;
 2040 END;
 2050
 2060 BEGIN
 2070   setupgralib;
 2080   setup;
 2090   screen;
 2100   scenery;
 2110   planets;
 2120   REPEAT
 2130    IF value=32 then kmreset;
 2140    ch1:=rdkey;
 2150    value:=ord(ch1);
 2160    IF value=32 THEN launch;
 2170   UNTIL value=252;
 2180 END.

[attachimg=2]

[AMSDOS]

I was going hyper over that hypno BASIC program from AA45 type-ins, so I've knocked it up with this. The result isn't quite right because I haven't figured out how to evaluate this loop:-

Code: [Select]

for x=-f to a step f


in Pascal.


f is a constant that equals 1000, so -f = -1000 & a is also a constant that equals 639. 


So in Pascal I've done

Code: [Select]

xpos:=-1000;
while (xpos<639) do begin
 xpos:=xpos+1000;
...


I've also tried variations by placing xpos:=xpos+1000; at the end of the while loop. So instead it looks like one of those Colour Rolling Effects you get on an Atari 2600 Logo.


[attachimg=3]


Update: Turned out it had nothing to do with the loop, loop was working just fine. But the BASIC program was checking:

Code: [Select]

if c>15 then c=1:d=d+1


My earlier program did this:

Code: [Select]

if col>15 then c:=1
depth:=depth+1


which was producing the extra colour. In Pascal it should look like this:

Code: [Select]

if col>15 then begin
  c:=1;
  depth:=depth+1;
end;


So depth only increments when col is greater than 15.


Oops. 


So my program now looks like this:

Code: [Select]


   10 PROGRAM HypnoStrobe;
   20 {$C-}
   30 (* Original Hypno Strobe/Colour Fader by Nigel Myers
   40    & Published IN Amstrad Action June 1989
   50    Fx & Ypos variable can be modified FOR different effect *)
   60
   70 VAR fx, mnloop                : integer;
   80     col, depth, entry         : integer;
   90     xpos, ypos                : integer;
  100     ch1                       : char;
  110
  120 { Procedures FOR Main PROGRAM }
  130
  140 PROCEDURE mode(no : char);
  150 BEGIN
  160   ra:=no;
  170   user(#bc0e);
  180 END;
  190
  200 FUNCTION rdkey : char;
  210 BEGIN
  220   user(#bb1b);
  230   rdkey:=ra;
  240 END;
  250
  260 PROCEDURE ink(ink,col1 : integer);
  270 BEGIN
  280   ra:=chr(ink);
  290   rb:=chr(col1);
  300   rc:=chr(col1);
  310   user(#bc32);
  320 END;
  330
  340 PROCEDURE border(col1 : char);
  350 BEGIN
  360   rb:=col1;
  370   rc:=col1;
  380   user(#bc38);
  390 END;
  400
  410 PROCEDURE move(x,y : integer);
  420 BEGIN
  430   rde:=x; rhl:=y;
  440   user(#bbc0);
  450 END;
  460
  470 PROCEDURE drawr(x,y, col : integer);
  480 BEGIN
  490   ra:=chr(col);
  500   user(#bbde);
  510   rde:=x;
  520   rhl:=y;
  530   user(#bbf9);
  540 END;
  550
  560 BEGIN
  570   ink(0,0); border(chr(0)); mode(chr(0));
  580   ch1:=CHR(0);
  590   col:=1;
  600   depth:=1;
  610   entry:=1;
  620   ypos:=0;
  630   REPEAT
  640      xpos:=-1000;
  650      WHILE (xpos<639) DO BEGIN
  660        xpos:=xpos+1000;
  670        move(xpos,ypos);
  680        drawr(639-xpos*2,0,col);
  690        move(xpos,399-ypos);
  700        drawr(639-xpos*2,0,col);
  710        move(639-xpos*2,ypos);
  720        drawr(0,399-ypos*2,col);
  730        move(xpos*2,ypos);
  740        drawr(0,399-ypos*2,col);
  750        ypos:=ypos+2;
  760        IF ypos>399 THEN ypos:=1;
  770        ink(col,depth);
  780        col:=col+1;
  790        IF col>15 THEN BEGIN
  800         col:=1;
  810         depth:=depth+1;
  820        END;
  830        IF depth>entry THEN depth:=entry-1;
  840      END;
  850   entry:=entry+1;
  860   IF entry>26 THEN entry:=1;
  870   ch1:=rdkey;
  880   mnloop:=ord(ch1);
  890   UNTIL mnloop=252;
  900 user(#bc02);
  910 mode(chr(2));
  920
  930 END.

I've also attached an updated file.


[attachimg=4]

[AMSDOS]

I made a small program to patch in a routine to increment a char type.


[attachimg=1]


I'm incrementing a Char type because there's no Byte Type in HP4T, the example I've used can be written in HP4T like this:

Code: [Select]

FOR num:=chr(32) to chr(255) do ...etc

but from time to time, you may get a variable with Byte attributes, but don't know where it's heading.

[AMSDOS]

Finally manage to write a function which uses KM TEST KEY to determine if a key is pressed. If a key has been pressed function returns as true, otherwise is false.




[attachimg=1]


The output as follows:


[attachimg=2]

[AMSDOS]

I can now move a character around the screen at a blistering pace with Test Key Function in place.

Code: [Select]

   10 PROGRAM MoveMan;
   20 {$C-}
   30
   40 VAR mx : integer;
   50     my : integer;
   60
   70 FUNCTION key(ch:char) : boolean;
   80 BEGIN
   90   inline(#DD,#7E,#02,
  100          #CD,#1E,#BB,
  110          #28,#05,
  120          #3E,#01,
  130          #DD,#77,#03);
  140 END;
  150
  160 PROCEDURE GOTOXY(x,y : INTEGER);
  170 BEGIN
  180   RH:=CHR(x);
  190   RL:=CHR(y);
  200   USER(#bb75);
  210 END;
  220
  230 PROCEDURE MoveMan;
  240 BEGIN
  250  IF key(chr(1))=true THEN
  260   BEGIN
  270     IF mx<80 THEN mx:=mx+1;
  280     Gotoxy(mx,my);
  290     write(chr(250));
  300     gotoxy(mx-1,my);
  310     write(' ');
  320   END;
  330  IF key(chr(8))=true THEN
  340   BEGIN
  350     IF mx>1 THEN mx:=mx-1;
  360     gotoxy(mx,my);
  370     write(chr(251));
  380     gotoxy(mx+1,my);
  390     write(' ');
  400   END;
  410  IF key(chr(0))=true THEN
  420   BEGIN
  430     IF my>1 THEN my:=my-1;
  440     gotoxy(mx,my);
  450     write(chr(248));
  460     gotoxy(mx,my+1);
  470     write(' ');
  480   END;
  490  IF key(chr(2))=true THEN
  500   BEGIN
  510     IF my<25 THEN my:=my+1;
  520     gotoxy(mx,my);
  530     write(chr(248));
  540     gotoxy(mx,my-1);
  550     write(' ');
  560   END;
  570 END;
  580
  590 BEGIN { Main Test PROGRAM }
  600 page;
  610 my:=12;
  620 mx:=40;
  630 gotoxy(mx,my);
  640 write(chr(249));
  650  REPEAT
  660   moveman;
  670  UNTIL key(chr(66))=true;
  680 END.




[AMSDOS]

I prepared some more routines as followup to the Routine which Increments Char Type in HP4T.

Code: [Select]


   10 PROGRAM count;
   20
   30 VAR num : char;
   40
   50 FUNCTION minusone(num : char) : char;
   60 BEGIN
   70   inline(#DD,#35,#2);
   80   minusone:=num;
   90 END;
  100
  110 FUNCTION dec(val, step : char) : char;
  120 BEGIN
  130   REPEAT
  140     inline(#DD,#35,#3);
  150     step:=minusone(step);
  160     dec:=val;
  170   UNTIL step=chr(0);
  180 END;
  190
  200 FUNCTION inc(val, step : char) : char;
  210 BEGIN
  220  REPEAT
  230   inline(#DD,#34,#3);
  240   step:=minusone(step);
  250   inc:=val;
  260  UNTIL step=chr(0);
  270 END;
  280
  290 BEGIN
  300  num:=chr(255);
  310   REPEAT
  320    num:=dec(num,chr(4));
  330    writeln(ord(num));
  340   UNTIL num<chr(5);
  350  user(#bb18);
  360  REPEAT
  370    num:=inc(num,chr(2));
  380    writeln(ord(num));
  390  UNTIL num>chr(250);
  400 END.

I've added 3 functions, minusone is used to reduce the step in the other 2 Functions inc & dec.  Those functions take 2 parameters now, "val" holds the start value & "step" how much it steps by, allowing "num:=num+step" in this environment for the 1 byte Char type.

[AMSDOS]

I've updated my routine to move the man character around the screen using GRA WR CHAR.

Code: [Select]

   10 PROGRAM gramoveman;
   20 {$C-}
   30
   40 VAR mx : integer;
   50     my : integer;
   60     storechar : char;
   70
   80 FUNCTION key(ch:char) : boolean;
   90 BEGIN
  100   inline(#DD,#7E,#02,
  110          #CD,#1E,#BB,
  120          #28,#05,
  130          #3E,#01,
  140          #DD,#77,#03);
  150 END;
  160
  170 PROCEDURE move(x,y : integer);
  180 BEGIN
  190   RDE:=x;
  200   RHL:=y;
  210   user(#bbc0);
  220 END;
  230
  240 PROCEDURE grawrchar(c, mde : char);
  250 BEGIN
  260   write(chr(23)); write(mde);
  270   ra:=c;
  280   user(#bbfc);
  290 END;
  300
  310 PROCEDURE MoveMan;
  320 BEGIN
  330  IF key(chr(1))=true THEN
  340   BEGIN
  350     IF mx<600 THEN mx:=mx+1;
  360     move(mx,my);
  370     grawrchar(chr(250),chr(1));
  380     move(mx-1,my);
  390     grawrchar(storechar,chr(1));
  400     storechar:=chr(250);
  410   END;
  420  IF key(chr(8))=true THEN
  430   BEGIN
  440     IF mx>2 THEN mx:=mx-1;
  450     move(mx,my);
  460     grawrchar(chr(251),chr(1));
  470     move(mx+1,my);
  480     grawrchar(storechar,chr(1));
  490     storechar:=chr(251);
  500   END;
  510  IF key(chr(0))=true THEN
  520   BEGIN
  530     IF my<390 THEN my:=my+2;
  540     move(mx,my);
  550     grawrchar(chr(248),chr(1));
  560     move(mx,my-2);
  570     grawrchar(storechar,chr(1));
  580     storechar:=chr(248);
  590   END;
  600  IF key(chr(2))=true THEN
  610   BEGIN
  620     IF my>16 THEN my:=my-2;
  630     move(mx,my);
  640     grawrchar(chr(248),chr(1));
  650     move(mx,my+2);
  660     grawrchar(storechar,chr(1));
  670     storechar:=chr(248);
  680   END;
  690 END;
  700
  710 BEGIN { Main Test PROGRAM }
  720 page;
  730 my:=200;
  740 mx:=320;
  750 move(mx,my);
  760 grawrchar(chr(249),chr(1));
  770 storechar:=chr(249);
  780  REPEAT
  790   moveman;
  800  UNTIL key(chr(66))=true;
  810 END.

I've made this error before where I'm getting to the edge of the area and when move that character, the xor effect of them leaves a partial image of them onscreen which looks quite funny. To get it working most of the time (draw/delete) I've created a variable to store it's character number and when I press another key the character changes to face that direction (apart from Up/Down which use the same char). I think the fault might be in not using variables with old values in them when I drawing out the old position, though this code may need further dividing instead of it being all together in the "moveman" procedure.


[attachimg=1]

[AMSDOS]

I was having some problems when I was trying to use my new char increment along with the test key routine. Somehow the conditioning from the key routine was returning True forcing the program to exit.


In this example I came up with, I've created a new variable type boolean and point the key routine to that,prior to carrying out a char increment. The only odd result here is when I press ESC, the program exits, the compiled version simply resets the computer back to basic, though in my REPEAT..UNTIL loop I've also got the program exiting once the character number reaches 255 and in that case the program returns the the RUN prompt.

Code: [Select]

   10 PROGRAM ExitOnKeyPress;
   20 {$C-}
   30 (* This PROGRAM uses the Firmware Test key AND exits when condition
   40    is true, though it also increments a char TYPE. UNTIL now
   50    the PROGRAM was exiting unexpectably when an increment OF char
   60    TYPE was taking place, though IF I place the check IN boolean
   70    TYPE "ch" AND check this before incrementing the char TYPE "num"
   80    PROGRAM functions AND will exit when ESC is pressed *)
   90
  100 VAR num : char;
  110     ch : boolean;
  120
  130 FUNCTION inc(num : char) : char;
  140 BEGIN
  150   inline(#DD,#34,#2);
  160   inc:=num;
  170 END;
  180
  190 FUNCTION key(ch:char) : boolean;
  200 BEGIN
  210   inline(#DD,#7E,#02,
  220          #CD,#1E,#BB,
  230          #28,#05,
  240          #3E,#01,
  250          #DD,#77,#03);
  260 END;
  270
  280 BEGIN
  290 num:=chr(0);
  300 REPEAT
  310   ch:=key(chr(66));
  320   num:=inc(num);
  330   writeln(ord(num));
  340 UNTIL (ch=true) OR (num=chr(255))
  350 END.

[AMSDOS]

All good now, the keypress routine from above was forcing the Compiler "Run (Y/N)" Option to make it believe I didn't want to run it anymore, hence the Reset. I've resolve it with a KMRESET (&BB03) to flush the keyboard buffer as the program exits.


So today I've rewritten another BASIC Demo which produces an amazing Mosiac Pattern in Mode 1, it looked great from BASIC, though the transition as a result of compiling it is stunning.

Code: [Select]


   10 PROGRAM Mosiac;
   20 (* Written IN BASIC by Nigel Myers, Published IN AA45 TYPE-ins *)
   30 {$C-}
   40
   50 VAR xpos : integer;
   60     ypos : integer;
   70     col1 : char;
   80     col2 : char;
   90     ch   : boolean;
  100
  110 FUNCTION inc(num : char) : char;
  120 BEGIN
  130   inline(#DD,#34,#02);
  140   inc:=num
  150 END;
  160
  170 FUNCTION key(ch:char) : boolean;
  180 BEGIN
  190   inline(#DD,#7E,#02,
  200          #CD,#1E,#BB,
  210          #28,#05,
  220          #3E,#01,
  230          #DD,#77,#03)
  240 END;
  250
  260 PROCEDURE kmreset;
  270 BEGIN
  280   user(#bb03)
  290 END;
  300
  310 PROCEDURE mode(num : char);
  320 BEGIN
  330   ra:=num;
  340   user(#bc0e)
  350 END;
  360
  370 PROCEDURE ink(ink,col : char);
  380 BEGIN
  390   ra:=ink;
  400   rb:=col;
  410   rc:=col;
  420   user(#bc32)
  430 END;
  440
  450 PROCEDURE border(col : char);
  460 BEGIN
  470   rb:=col;
  480   rc:=col;
  490   user(#bc38)
  500 END;
  510
  520 PROCEDURE move(x,y : integer);
  530 BEGIN
  540   rde:=x; rhl:=y;
  550   user(#bbc0)
  560 END;
  570
  580 PROCEDURE drawr(x,y : integer;col : char);
  590 BEGIN
  600   ra:=col;
  610   user(#bbde);
  620   rde:=x;
  630   rhl:=y;
  640   user(#bbf9)
  650 END;
  660
  670 FUNCTION rnd(range : integer) : integer;
  680 VAR seed   : integer;
  690     result : real;
  700 BEGIN
  710   seed:=random(0);
  720   result:=(range/maxint);
  730   result:=(seed*result);
  740   rnd:=trunc(result)
  750 END;
  760
  770 BEGIN
  780   mode(chr(1));
  790   ink(chr(0),chr(0));
  800   ink(chr(1),chr(6));
  810   ink(chr(2),chr(18));
  820   ink(chr(3),chr(11));
  830   border(chr(0));
  840   write(chr(23));
  850   write(chr(1));
  860   col1:=chr(1);
  870   col2:=chr(0);
  880   xpos:=1;
  890   ypos:=1;
  900   REPEAT
  910     ch:=key(chr(66));
  920     move(xpos,ypos);
  930     drawr(639-xpos*2,0,col1);
  940     move(xpos,399-ypos);
  950     drawr(639-xpos*2,0,col1);
  960     move(xpos,ypos);
  970     drawr(0,399-ypos*2,col2);
  980     move(639-xpos,ypos);
  990     drawr(0,399-ypos*2,col2);
 1000     ypos:=ypos+2;
 1010     IF ypos>399 THEN BEGIN
 1020        ypos:=1;
 1030        col2:=chr(rnd(4))
 1040     END;
 1050     xpos:=xpos+4;
 1060     IF xpos>639 THEN BEGIN
 1070        xpos:=1;
 1080        col1:=inc(col1)
 1090     END;
 1100     IF col1>chr(3) THEN col1:=chr(1);
 1110   UNTIL ch=true;
 1120   kmreset
 1130 END.


[attachimg=1]

[AMSDOS]

Until now I hadn't played around with Windows using this language. I had a program demonstrating this in Turbo Pascal 3 and when I had a look at it, appeared to be more involved than what I remembered.


My version here simply addresses the Firmware Direct, to setup each Window, a Stream is first selected and then a Window is defined. When I want to write to that window, I can then Select the stream, apply some attributes to it (Paper, Pen & ClearWindow effect), and write to that using standard write command.

[AMSDOS]

When I first started using this language, my program was loading a data file by using the TIN(); TOUT(); Procedures to Load & Save a Data file with a set filename assigned to it. I haven't written a Program which asks for a Filename and sets out to load it, but I've defined a Procedure called load and the filename from the character array gets passed to TIN();, which works.


[attachimg=1]

[AMSDOS]

This is what I came up with which asks for a filename for a DAT file and displays some of the contents of it.

Code: [Select]


   10 PROGRAM LoadInDataFile;
   20
   30 TYPE file = ARRAY[1..12] OF char;
   40
   50 VAR
   60   data : ARRAY[0..9] OF INTEGER;
   70   name : ARRAY[1..12] OF char;
   80   count : integer;
   90
  100 PROCEDURE load(fn : file);
  110 BEGIN
  120   tin(fn,addr(data))
  130 END;
  140
  150 BEGIN
  160 write('Please Enter a Filename :');
  170 readln;
  180 read(name);
  190 count:=1;
  200 REPEAT
  210   WHILE (name[count]=chr(0)) DO
  220     name[count]:=chr(32);
  230   count:=count+1;
  240 UNTIL count=12;
  250 name[9]:='.';
  260 name[10]:='D';
  270 name[11]:='A';
  280 name[12]:='T';
  290 load(name);
  300 FOR count:=0 TO 9 DO
  310   write(data[count]);
  320   write(' ');
  330 END.




Due to the complexity of the TIN procedure, the length of the filename must be 12 Characters in Length. In order to make it work, the user enters the name of the file which gets stored in the name array, but TIN won't work unless the Length is 12 Characters Long. For the extension Positions 9 to 12 of the name array are used, but if the name is less than 8 characters, a Bad Command is returned, which is where the REPEAT & WHILE Loops are used, which simply looks for any Zeros in the Array and changes them to Spaces, which is what TIN requires if a filename doesn't equal 8 characters. The Repeat Until Loop simply Increments the count so the next position of the array can be check for any Zero and change it accordingly in the While.

[AMSDOS]

I put together this small program which demonstrates passing values from one Array to another, up to now all I've done is setup two or more arrays or have an Procedure focusing on a Globally defined Array, and thought it would be good to be able to make a Procedure which could tackle any array assigned to it.

Code: [Select]

   10 PROGRAM PassArray;
   20
   30 VAR myarry : ARRAY[1..10] OF char;
   40     num1   : integer;
   50
   60 PROCEDURE starry(num,na : char);
   70 VAR arry : ARRAY[1..10] OF char;
   80     loop : char;
   90 BEGIN
  100    arry[ord(na)]:=num;
  110    writeln(ord(arry[ord(na)]))
  120 END;
  130
  140 PROCEDURE setupmyarry;
  150 BEGIN
  160   myarry[1]:=chr(1);
  170   myarry[2]:=chr(26);
  180   myarry[3]:=chr(15);
  190   myarry[4]:=chr(2);
  200   myarry[5]:=chr(6);
  210   myarry[6]:=chr(3);
  220   myarry[7]:=chr(25);
  230   myarry[8]:=chr(9);
  240   myarry[9]:=chr(13);
  250   myarry[10]:=chr(11);
  260 END;
  270
  280 BEGIN
  290   setupmyarry;
  300   num1:=1;
  310   WHILE (num1<=10) DO
  320   BEGIN
  330     starry(myarry[num1],chr(num1));
  340     num1:=num1+1
  350   END;
  360 END.


[AMSDOS]

Will need to revise program above, not that the program above has no use, but Passing values from an Array through a Procedure could simply be a set of Variables (not an array), which could then carry out an operation. As my program above shows, a loop needs to be carried out to go through all the values in myarry, the local arry will then just take the value from myarry one at a time and print that in the Procedure I made. So the "starry" procedure could be changed to:

Code: [Select]

Procedure starry(num : char);
begin
  written(ord(num));
end;


And would give the same result as long as line 330 looked like this:

Code: [Select]

      starry(myarry[num1]);