Jump to content
IGNORED

Mad Pascal examples


Gury

Recommended Posts

Let's go for some sort speed tests. Back in the days we also tested, if the sort algs work correct. That is a todo for the a8 version. I assume it will work fine too - expect for "Mischsort" (mix sorting) where a field length of more than 256 causes in endless computing.

 

TurboPascal (or even PurePascal for ST friends, I coded at home with it, too) source included in zip

 

post-3781-0-41412500-1468006350_thumb.pngpost-3781-0-57029100-1468006364_thumb.png

{--Turbo Pascal 1993-----------------Mad Pascal 2016--}
{-- some sorting tests we had to do in school time  --}
{-- interesting is the fact that ripple with little --}
{-- difference matters in executing time            --}
{--                         I did the faster one  --}
{-- the a8 version has sme limits: if max>255 the   --}
{-- mix sort does not work - no deep look in that   --}
{-- have fun trying out to understand the code    --}
{-------------------------------------------PPs 2016--}
uses crt,dos;

const    max=1500;

type     field=array[0..max] of word;

var      test,feld:field;
   h,h1,m,m1,s,s1,hund,j:word;
		ii:byte;

{----------------------------------------------------------------------}
procedure ausgabe(h,h1,m,m1,s,s1:word);
var       h2,m2,s2:integer;
begin
 if s1<s then begin
    s2:=60-(s-s1);
    dec(m1);
 end
 else s2:=s1-s;
 if m1<m then m2:=60-(m-m1)
 else m2:=m1-m;
 h2:=h1-h;
 writeln(h2,' h ',m2,' m ',s2,' s ');
 writeln;
end;
{----------------------------------------------------------------------}
procedure testmenge(var menge:field);

var       i:word;

begin
 randomize;
 for i:=1 to max do
     menge[i]:=random(65535);
end;
{----------------------------------------------------------------------}
procedure bubble(feld:field);

var       t:boolean;
          x,i:word;
          tausch:word;

begin

 write('Bubblesort:                           ');

 gettime(h,m,s,hund);
 t:=true;
 x:=max;
 while t=true do begin
       dec(x);
       for i:=1 to x do
              if feld[i]>feld[i+1] then begin
              tausch:=feld[i];
              feld[i]:=feld[i+1];
              feld[i+1]:=tausch;
              t:=true;
           end
           else if x=2 then t:=false;
 end;
 gettime(h1,m1,s1,hund);
end;
{----------------------------------------------------------------------}
procedure ripple(feld:field);
var       i,j:word;
          pos:word;
    test,hold:word;

begin

 write('Ripplesort (made by R.Patschke):      ');

 gettime(h,m,s,hund);
 for i:=1 to max-1 do begin
     test:=feld[i];
     hold:=test;
     pos:=i;
     for j:=i+1 to max do
         if feld[j]<test then begin
            test:=feld[j];
            pos:=j;
         end;
     feld[i]:=test;
     feld[pos]:=hold;
 end;
 gettime(h1,m1,s1,hund);
end;
{----------------------------------------------------------------------}
procedure einfueg(von,bis:integer;
                 var feld:field);
var       i,j,test,pos:word;

begin
 for i:=von to bis-1 do begin;
     test:=feld[i];
     pos:=i;
     for j:=i+1 to bis do
         if feld[j]<test then begin
            test:=feld[j];
            pos:=j;
         end;
     for j:=pos-1 downto i do feld[j+1]:=feld[j];
     feld[i]:=test;
 end;
 gettime(h1,m1,s1,hund);
end;
{----------------------------------------------------------------------}
procedure gabler(feld:field);
var i,n,k,tausch:word;
begin

 write('Ripplesort (made by J.Gabler):        ');

 gettime(h,m,s,hund);
 for i:=1 to max-1 do begin
     n:=i;
     for k:=i+1 to max do
         if feld[n]>feld[k] then n:=k;
     if n>i then begin
        tausch:=feld[i];
        feld[i]:=feld[n];
        feld[n]:=tausch;
     end;
 end;
 gettime(h1,m1,s1,hund);
end;
{----------------------------------------------------------------------}
procedure mischsort(test:field);

var      feld:field;
         dummy:boolean;
         v,i,links,rechts,lgr,rgr:word;


begin

 write('Sortieren mit Mischen:                ');

 gettime(h,m,s,hund);
 lgr:=max div 2;
 rgr:=lgr+1;
 einfueg(1,lgr,test);
 einfueg(rgr,max,test);
 i:=1;
 links:=i;
 rechts:=rgr;
 dummy:=false;
 repeat
       if test[links]<test[rechts] then begin
          feld[i]:=test[links];
          inc(i);
          inc(links);
          if links=rgr then begin
             for v:=rechts to max do begin
                 feld[i]:=test[v];
                 inc(i);
             end;
             dummy:=true;
          end;
       end
       else begin
          feld[i]:=test[rechts];
          inc(i);
          inc(rechts);
          if rechts>max then begin
             for v:=links to rgr do begin
                 feld[i]:=test[v];
                 inc(i);
             end;
             dummy:=true;
          end;
       end;
 until dummy=true;
 gettime(h1,m1,s1,hund);
end;
{----------------------------------------------------------------------}
begin
 clrscr;

 write('Anzahl der Feldelemente: ');

 writeln(max);
 writeln;
 testmenge(test);
 for ii:=1 to 5 do begin
     case ii of
          1:bubble(test);
          2:ripple(test);
          3:gabler(test);
          4:begin
                 for j:=1 to max do feld[j]:=test[j];

                 write('Sortieren durch Einfuegen:            ');

                 gettime(h,m,s,hund);
                 einfueg(1,max,feld);
                 gettime(h1,m1,s1,hund);
            end; 
          5:if max<256 then mischsort(test);
     end;
     if ii=5 then begin
	if max<256 then ausgabe(h,h1,m,m1,s,s1);
     end
     else ausgabe(h,h1,m,m1,s,s1);
 end;

 writeln('Taste druecken !!!');
 repeat until keypressed;
end.

wrong attachement erased...

sort.zip

Edited by pps
Link to comment
Share on other sites

Ahh, seems that I got an error... field creation with random(65535) does produce only entries with 0 instead randomly between 0 and 65535. I changed it to 32000 and it works.

 

Everything is fine now ;)

 

post-3781-0-91643300-1468007931_thumb.png

{--Turbo Pascal 1993-----------------Mad Pascal 2016--}
{-- some sorting tests we had to do in school time  --}
{-- interesting is the fact that ripple with little --}
{-- difference matters in executing time            --}
{--                         I did the faster one  --}
{-- the a8 version has some limits: if max>255 the  --}
{-- mix sort does not work - no deep look in that   --}
{-- have fun trying out to understand the code    --}
{-----------------------corrected version---PPs 2016--}
uses crt,dos;

const    max=1500;

type     field=array[0..max] of word;

var      test,feld:field;
   h,h1,m,m1,s,s1,hund,j:word;
		ii:byte;

{----------------------------------------------------------------------}
procedure ausgabe(h,h1,m,m1,s,s1:word);
var       h2,m2,s2:integer;
begin
 if s1<s then begin
    s2:=60-(s-s1);
    dec(m1);
 end
 else s2:=s1-s;
 if m1<m then m2:=60-(m-m1)
 else m2:=m1-m;
 h2:=h1-h;
 writeln(h2,' h ',m2,' m ',s2,' s ');
 writeln;
end;
{----------------------------------------------------------------------}
procedure testmenge(var menge:field);

var       i:word;

begin
 randomize;
 for i:=1 to max do
     menge[i]:=random(32000);
end;
{----------------------------------------------------------------------}
procedure bubble(feld:field);

var       t:boolean;
          x,i:word;
          tausch:word;

begin

 write('Bubblesort:                           ');

 gettime(h,m,s,hund);
 t:=true;
 x:=max;
 while t=true do begin
       dec(x);
       for i:=1 to x do
              if feld[i]>feld[i+1] then begin
              tausch:=feld[i];
              feld[i]:=feld[i+1];
              feld[i+1]:=tausch;
              t:=true;
           end
           else if x=2 then t:=false;
 end;
 gettime(h1,m1,s1,hund);
end;
{----------------------------------------------------------------------}
procedure ripple(feld:field);
var       i,j:word;
          pos:word;
    test,hold:word;

begin

 write('Ripplesort (made by R.Patschke):      ');

 gettime(h,m,s,hund);
 for i:=1 to max-1 do begin
     test:=feld[i];
     hold:=test;
     pos:=i;
     for j:=i+1 to max do
         if feld[j]<test then begin
            test:=feld[j];
            pos:=j;
         end;
     feld[i]:=test;
     feld[pos]:=hold;
 end;
 gettime(h1,m1,s1,hund);
end;
{----------------------------------------------------------------------}
procedure einfueg(von,bis:integer;
                 var feld:field);
var       i,j,test,pos:word;

begin
 for i:=von to bis-1 do begin;
     test:=feld[i];
     pos:=i;
     for j:=i+1 to bis do
         if feld[j]<test then begin
            test:=feld[j];
            pos:=j;
         end;
     for j:=pos-1 downto i do feld[j+1]:=feld[j];
     feld[i]:=test;
 end;
 gettime(h1,m1,s1,hund);
end;
{----------------------------------------------------------------------}
procedure gabler(feld:field);
var i,n,k,tausch:word;
begin

 write('Ripplesort (made by J.Gabler):        ');

 gettime(h,m,s,hund);
 for i:=1 to max-1 do begin
     n:=i;
     for k:=i+1 to max do
         if feld[n]>feld[k] then n:=k;
     if n>i then begin
        tausch:=feld[i];
        feld[i]:=feld[n];
        feld[n]:=tausch;
     end;
 end;
 gettime(h1,m1,s1,hund);
end;
{----------------------------------------------------------------------}
procedure mischsort(test:field);

var      feld:field;
         dummy:boolean;
         v,i,links,rechts,lgr,rgr:word;


begin

 write('Sortieren mit Mischen:                ');

 gettime(h,m,s,hund);
 lgr:=max div 2;
 rgr:=lgr+1;
 einfueg(1,lgr,test);
 einfueg(rgr,max,test);
 i:=1;
 links:=i;
 rechts:=rgr;
 dummy:=false;
 repeat
       if test[links]<test[rechts] then begin
          feld[i]:=test[links];
          inc(i);
          inc(links);
          if links=rgr then begin
             for v:=rechts to max do begin
                 feld[i]:=test[v];
                 inc(i);
             end;
             dummy:=true;
          end;
       end
       else begin
          feld[i]:=test[rechts];
          inc(i);
          inc(rechts);
          if rechts>max then begin
             for v:=links to rgr do begin
                 feld[i]:=test[v];
                 inc(i);
             end;
             dummy:=true;
          end;
       end;
 until dummy=true;
 gettime(h1,m1,s1,hund);
end;
{----------------------------------------------------------------------}
begin
 clrscr;

 write('Anzahl der Feldelemente: ');

 writeln(max);
 writeln;
 testmenge(test);
 for ii:=1 to 5 do begin
     case ii of
          1:bubble(test);
          2:ripple(test);
          3:gabler(test);
          4:begin
                 for j:=1 to max do feld[j]:=test[j];

                 write('Sortieren durch Einfuegen:            ');

                 gettime(h,m,s,hund);
                 einfueg(1,max,feld);
                 gettime(h1,m1,s1,hund);
            end; 
          5:mischsort(test);
     end;
     ausgabe(h,h1,m,m1,s,s1);
 end;
 writeln('Taste druecken !!!');
 repeat until keypressed;
end.

sort.zip

Edited by pps
Link to comment
Share on other sites

this is wrong

 

 

while t=true do begin
dec(x);
for i:=1 to x do
if feld[i]>feld[i+1] then begin
tausch:=feld[i];
feld[i]:=feld[i+1];
feld[i+1]:=tausch;
t:=true;
end
else if x=2 then t:=false;
end;

 

this case 'if x=2 then t:=false;' never happen and created big loop

 

Mad Pascal accept this situation (i: word)

 

for i:=1 to -10 

this should be an error

Link to comment
Share on other sites


// http://wiki.freepascal.org/Bubble_sort
// http://pascal-programming.info/articles/sorting.php
 
uses crt, sysutils;
 
const
      max = 256;
 
type
      TItemBubbleSort = byte;
      field = array [0..max-1] of TItemBubbleSort;
 
var
      i: word;
      s: cardinal;
 
      tb: field;
 
 
procedure BubbleSort( a: field );
var
   n, newn, i: word;
   temp: TItemBubbleSort;
begin
  n := high( a );
  repeat
    newn := 0;
    for i := 1 to n do
      begin
        if a[ i - 1 ] > a[ i ] then
          begin
            temp := a[ i - 1 ];
            a[ i - 1 ] := a[ i ];
            a[ i ] := temp;
 
            newn := i ;
          end;
      end ;
    n := newn;
  until n = 0;
 
end;
 
 
Procedure BubbleSort2( numbers : field );
Var
   i, j, size : word;
   temp: TItemBubbleSort;
 
Begin

size := High(numbers);
 
For i := size DownTo 0 do
  For j := 1 to i do
   If (numbers[j-1] > numbers[j]) Then
   Begin
    temp := numbers[j-1];
    numbers[j-1] := numbers[j];
    numbers[j] := temp;
   End;

end;
 
 
begin
 
 for i:=0 to max-1 do tb[i]:=max-i-1;
 
 write('Bubble sort, ',max,' elements');
 s:=GetTickCount; BubbleSort(tb); writeln(', ',GetTickCount-s,' ticks');
 
 write('Bubble sort2, ',max,' elements');
 s:=GetTickCount; BubbleSort2(tb); writeln(', ',GetTickCount-s,' ticks');
 
 repeat until keypressed;
 
end.

 

parameter by VAR, BubbleSort: 245 ticks

parameter by VAR, BubbleSort2: 221 ticks

parameter without VAR, BubbleSort: 213 ticks

parameter without VAR, BubbleSort2: 189 ticks

Edited by tebe
Link to comment
Share on other sites


// http://pascal-programming.info/articles/sorting.php

// Insertion Sort algorithm is a bit more efficient sorting algorithm than Bubble Sort.
// As it name implies, the insertion sort algorithm inserts an unsorted item in an already sorted item list.
// This makes you think of the use of two seperated arrays - one unsorted and the other sorted.
// However, to save space one uses the same array and uses a pointer to separate the sorted and unsorted elements of the list.

// The sorting time complexity of the Insertion Sort is O(n2).
// Although this exactly the same to Bubble Sort's, the Insertion Sort algorithm is twice more efficient, yet inefficient for large lists.

uses crt, sysutils;

const
max = 256;

type
TItemSort = byte;
field = array [0..max-1] of TItemSort;

var
i: word;
s: cardinal;

tb: field;


Procedure InsertionSort( numbers : field );
Var
i, j, index, size : word;

Begin
size := high(numbers);

For i := 1 to size do
Begin
index := numbers[i];
j := i;

While ((j > 0) AND (numbers[j-1] > index)) do
Begin
numbers[j] := numbers[j-1];
dec(j);
End;

numbers[j] := index;
End;

end;


begin

for i:=0 to max-1 do tb[i]:=max-i-1;

write('Insertion sort, ',max,' elements');
s:=GetTickCount; InsertionSort(tb); writeln(', ',GetTickCount-s,' ticks');

repeat until keypressed;

end.

parameter by VAR: 179 ticks

parameter without VAR: 144 ticks

 

Edited by tebe
Link to comment
Share on other sites

this is wrong

while t=true do begin
dec(x);
for i:=1 to x do
if feld[i]>feld[i+1] then begin
tausch:=feld[i];
feld[i]:=feld[i+1];
feld[i+1]:=tausch;
t:=true;
end
else if x=2 then t:=false;
end;

this case 'if x=2 then t:=false;' never happen and created big loop

What is wrong there?

 

i starts at 1 and goes to max (in the first run) as x is set to max before the loop. Each time x is decreased and will for sure become 2 at some time. Then in the first run feld[1] and feld[] is testet and will be switched, when needed. Then i will become 2 and feld[2] and feld[3] is tested, what always should be sorted right now - so we get into else state, where x is asked if it is 2, then we got out of the loop.

 

The feld[0] is not tested here, because the original code has a feld array from 1 to max - MadPascal doesn't accepts this, so I set it starting from 0 onwards. I simply did not change the rest of the code, as every sort alg in it assumes that feld starts with feld[1].

 

And hey, this was code on old ancient DOS computers ;) No internet, no mobile phones and my ATARI Falcon with built in hardware 286 emulation had more power than a native PC, so Win 3.11 had greater VGA 16 resolution, than VGA standard had then (only 800*600 - the Falcon got around 1186*832 (VGA 256 had more than 800*600 too).

Link to comment
Share on other sites

QuickSort (Mad Pascal 1.3.9)

 

 

uses crt, sysutils;
 
const 
size = 256;
 
type
field = array [0..size-1] of byte;
 
var
i: word;
s: cardinal;
 
numbers: field;
 
 
procedure QuickSort(Left, Right: word);
var
  ptrLeft, ptrRight, Pivot, Temp: word;
begin
 
  ptrLeft := Left;
  ptrRight := Right;
  Pivot := numbers[(Left + Right) shr 1];
 
  repeat
 
    while (ptrLeft < Right) and (numbers[ptrLeft] < Pivot) do inc(ptrLeft);
    while (ptrRight > Left) and (numbers[ptrRight] > Pivot) do dec(ptrRight);
 
    if ptrLeft <= ptrRight then  
      begin
        if ptrLeft < ptrRight then
          begin
            Temp := numbers[ptrLeft];
            numbers[ptrLeft] := numbers[ptrRight];
            numbers[ptrRight] := Temp;
          end;
        inc(ptrLeft);
        dec(ptrRight);
     end;
 
  until ptrLeft > ptrRight;
 
  if ptrRight > Left then QuickSort(Left, ptrRight);
  if ptrLeft < Right then QuickSort(ptrLeft, Right);
 
end;   
 
 
begin
 
 for i:=0 to size-1 do numbers[i]:=size-i-1;
 
 write('Quick sort, ',size,' elements');
 
 s:=GetTickCount; 
 
 QuickSort(0, size-1);
 
 writeln(', ',GetTickCount-s,' ticks');
 
 repeat until keypressed;
 
end.
  • Like 2
Link to comment
Share on other sites

  • 2 weeks later...
  • 2 weeks later...

Hi all,

 

I need to show the loaded operating system, made the following routine but not if it's okay.

procedure VersionOS;
begin
  case Hi(DosVersion) of
  0   : writeln('SpartaDOS 2.3');
  13  : writeln('DOS 4.0');
  15  : writeln('SpartaDOS 1.1');
  19  : writeln('Atari DOS 2.5');
  76  : writeln('Atari DOS 3.0');
  78  : writeln('Atari DOS 3.0');
  89  : writeln('SpartaDOS 3.2d');
  108 : writeln('MYDOS 4.00');
  207 : writeln('OSS OS/A+ 4.00');
  221 : writeln('MYDOS 4.50');
  238 : writeln('OSS DOS XL 2.3');
  244 : writeln('Atari DOS XE');
  124 : writeln('Atari DOS 2.0s');
  255 : writeln('None');
  end;
end;

regards

Link to comment
Share on other sites

  • 2 weeks later...

 

(*
 Invaders
 2016-03-25
 (C) 2016 by Victor Parada
 <HTTP://www.vitoco.cl/atari/>
*)
 
program invaders;
 
uses crt, graph, joystick, math;
 
const
k : array [0..77] of byte = 
(
$08,$3E,$7F,$7F,$1F,$CF,$9F,$18,$48,$C8,$96,$FF,$FF,$FF,$FF,$FF,$01,$01,$03,$03,$55,$47,$40,$BC,$07,$56,$0C,$BE,$16,$01,$03,$07,
$0D,$0F,$02,$05,$0A,$80,$C0,$E0,$B0,$F0,$40,$A0,$50,$04,$02,$07,$0D,$1F,$17,$14,$03,$10,$20,$F0,$D8,$FC,$F4,$14,$60,$03,$1F,$3F,
$39,$3F,$06,$0D,$30,$C0,$F8,$FC,$9C,$FC,$60,$B0,$0C,$2C
);
 
var
q, p, m, w, e, s, r, c, tmp: word;
 
d, g, x, f, i, j, z, t,
u, l, h, v, o, y, a, b: byte;
 
ch: char;
 
tX, tM, tF: array [0..1] of byte;
tI: array [0..8] of byte;
tJ: array [0..5] of byte;
 
begin
 
 
repeat
 
 InitGraph(24);
 InitGraph(0);
 
 q:=dpeek($230) + 8; 
 
 move(k[21], pointer(q-5), ;
 
 for c:=q+3 to q+3+16 do poke(c, peek(q+2));
 
 P:=$D000; M:=$D404;
 
 POKE(M,0); POKE (M+3,184); 
 POKE(559,46); POKE($D01D,3);
 
 MOVE(pointer($E000), pointer($B000), 512); // Copies the first half of the charset into RAM, and replaces some chars with alien's bitmap.
 MOVE (K[29], pointer($B008), 48);
 
 z:=1; // Sets the initial index value for the arrays. Z is 1 when the invaders are moving to the right, and 0 if going to the left.
 d:=1; // Sets the initial horizontal moving direction of the invaders to the right (1=right, -1=left).
 t:=54; // Number of aliens in the block.
 
 MOVE (K, pointer($BA68), 4); // Puts the cannon bitmap in P0 data.
  
 MOVE (K[8], pointer(P), 13); // Set the initial horizontal position and width for all players and missiles.
 
 U:=1;
 L:=5;
 
 POKE(756,$B0);
 
 W:=$B99C; E:=$BAEC; S:=$BE0E;
 R:=S-2; // R is dynamic memory position of the first displayed byte of the playfield. Will be decreased to move the block to the right.
 
 MOVE (K[3], pointer(704), ; // Sets the playfield and P/M graphics colors.
 
 i:=0; j:=0; b:=0; y:=0; h:=0; g:=0; v:=0; o:=0; x:=0; f:=0; tmp:=0;
 
 tX[1]:=8;
 tM[1]:=8;
 tF[1]:=14;
 
 A:=72;
 
 FOR J:=0 TO 5 do 
  FOR I:=0 TO 8 do begin
   DPOKE (S+J*48+I*2, $4242*((J+2) div 2)-1);
   tI[I]:=6;
   tJ[J]:=9;
  end;
 
 WHILE (Y+L*2<18) AND (C and 257=0) AND (T<>0) do begin
 
  POKE($D01E,1);
  u:=u+2;
  
  H:=STICK0;
  
  G:=ord(H=7)-ord(H=11);
 
  IF (byte(A+G)>46) AND (byte(A+G)<192) then begin
   A:=A+G*2;
   POKE(P,A); 
  end; 
  
  IF V=STRIG0 then begin
   B:=A+8;
   V:=4;
   POKE(P+1, B);  
  end;
 
  MOVE(pointer(W), pointer(W+2), 78);  
  O:=(O+1) MOD 36;
 
  IF O MOD 9=0 then begin 
   H:=O DIV 9;   
   I:=random(byte(tX[1]-tX[0]+1))+tX[0];
 
   IF tI[I]<>0 then begin 
    POKE(P+4+H,(X+I)*16+F+55);
    tmp:=W+tI[I]*8+Y*4;
    DPOKE(tmp, $0202*power(4,H));
   end;
 
  end;
 
  pause(2);
  
  C:=DPEEK(P+ or DPEEK(P+10);
 
  IF V<>0 then begin
    
    IF PEEK(P+5)<>0 then begin 
     I:=(B-F) DIV 16-X-3;
     J:=((76-V) DIV 4-Y) DIV 2;
     SOUND(1,8,8,9);
     DPOKE( S+J*48+I*2,0);
     tI[I]:=tI[I]-1;
     tJ[J]:=tJ[J]-1;
     T:=T-1;
     C:=C or 2;
    end; 
 
   DPOKE(E-V,0);
  
   IF (V<84) AND (C and  514=0) then begin    
    V:=V+2;
    DPOKE( E-V,$8080);
   end else
    V:=0;
 
  end;   
 
 
 IF U>T then begin
   
  SOUND(0,255,10,;
  U:=1;
  
  IF F=tF[Z] then begin 
   tX[Z]:=tX[Z]-D*ord(tI[tX[Z]]=0);
   
   IF tX[Z]+X=tM[Z] then begin
    D:=-D;
    Z:=1-Z;
    L:=L-ord(tJ[L]=0);
    R:=R-24;
    Y:=Y+1;
   end ELSE begin
    R:=R-D-D;
    X:=X+D;
    F:=tF[1-Z];
   end;
   
   PAUSE;
   DPOKE(Q,R);
 
 end ELSE begin
  F:=F+D+D;
  PAUSE;
 end;
 
 POKE(M,F);
end;
 
NoSound;
 
end;  // while
 
 IF T<>0 then
  DPOKE($BA69, $2A55)
 ELSE
  writeln('WIN');
 
 
repeat until keypressed;
 
ch:=readkey;
 
until false; 
 
end.
 

invaders.zip

  • Like 2
Link to comment
Share on other sites

  • 2 weeks later...

http://atariage.com/forums/blog/387/entry-10826-jump/

 

 

uses crt, joystick, graph, atari;
 
const SP = $E2A0;
PM = $A200;
SC = $BE70;
D  = $BE54;
CC = 200;
 
pl: array [0..83] of byte = (
$55,$FF,$55,$FF,$00,$00,$00,$00,$FF,$FF,$00,$00,$00,$AA,$55,$AA,$55,$AA,$00,$00,$00,$00,$00,$AA,$AA,$AA,$AA,$00,$00,$00,$00,$00,
$00,$00,$AA,$FF,$AA,$00,$00,$00,$00,$00,$55,$FF,$55,$FF,$55,$FF,$55,$00,$00,$00,$79,$60,$51,$3C,$90,$79,$60,$48,$51,$40,$35,$28,
$2D,$35,$40,$51,$48,$3C,$2D,$23,$28,$35,$40,$51,$5B,$48,$35,$2D,$28,$35,$40,$51
);
 
var s2, sb, r, e, s, h: word;
 
f, j, x, y: byte;
 
a, g, n, m: real;
 
label loop;
 
 
begin
 
loop: ;
 
InitGraph(3 + 16);
crsinh:=1;
 
pmbase:=hi(pm);
gractl:=2;
sdmctl:=$2e;
gprior:=1;
 
POKE (704,$38);
 
POKE(D-3,$68); 
 
fillByte(pointer(d), 18, $28);
 
MOVE (pointer(SC), pointer(PM), 128);
 
write('SCORE:'#$7f,S);
 
IF S>H then begin
H:=S;
write(#$7f'GREAT!');
end;
 
writeln;
writeln('HISCORE:'#$7f,H);
 
writeln(#$20#$09#$20#$0f#$09#$20#$15#$15#$20#$15#$0f#$19#$19#$19);
write(#$09#$8c#$20#$8b#$8c#$20#$89#$8f#$20#$89#$0c#$0f#$0f#$0f);
 
WHILE STRIG0<>0 do;
 
ClrScr;
 
S2:=SC+10;
SB:=SC+190;
 
Y:=20;
A:=0.2;
G:=0.2;
 
X:=120;
 
N:=0.0;
M:=0.0;
S:=0;
 
SOUND (0,0,10,10);
 
R:=$FE46;
E:=R+$FF;
 
atract:=0;
 
repeat
 
J:=STICK0;
 
IF J<8 then begin
 
 IF M<1.0 THEN M:=M+A;
 
end ELSE
  IF (J<13) AND (M>-1.0) THEN M:=M-A; 
 
IF p0pf<>0 then begin 
N:=-0.6;
hitclr:=0;
end else
IF N<1.5 then N:=N+G;
 
X:=X+round(M);
Y:=Y+round(N);
 
MOVE(pointer(SP),pointer(PM+Y),9);
hposp0:=x;
 
IF (Y>130) OR (Y<10) OR (X>250) OR (X<5) then begin 
NoSOUND;
GOTO loop;
end;
 
inc(f);
PAUSE;
 
IF F>7 then begin
vscrol:=0;
MOVE (pointer(S2), pointer(SC), CC);
 
IF (S and 7)=0 then begin
 
MOVE(PL[PEEK(R) and 31], pointer(SB), 10);
inc(r, ;
 
IF R>E then R:=R-$FF;
end;
 
F:=0;
MOVE (pl[52+(S and 31)], @audf1, 1);
inc(s);
end;
 
vscrol:=f;
 
until false;
 
end.

jump.zip

  • Like 1
Link to comment
Share on other sites

 

// Koch Snowflake
// https://en.wikipedia.org/wiki/Koch_snowflake
 
uses crt, graph;
 
type
TFloat = real;
 
FPoint =
RECORD
 x: TFloat;
 y: TFloat;
END;
 
var
gd, gm: integer;
 
const
cx = 160;
cy = 100;
 
ray0 = 70.0;
ray1 = ray0 / 2.0;
 
iteration = 3;
 
 
 
procedure LineTo2D(ax, ay: TFloat);
begin
 
 LineTo(round(ax)+cx, round(ay)+cy);  
  
end;
 
 
procedure MoveTo2D(ax, ay: TFloat);
begin
 
 MoveTo(round(ax)+cx, round(ay)+cy); 
 
end;
 
 
    PROCEDURE NextSegments (ax,ay,bx,by: TFloat; n:  byte);
      CONST
        factor =  0.288675135;  { SQRT(3) / 6 }
      VAR
        middle:  FPoint;
        xDelta:  TFloat;
        yDelta:  TFloat;
        r,s,t:  FPoint;
    BEGIN
 
      IF   n > 0
      THEN BEGIN
        r.x :=      (2.0*ax +     bx) / 3.0;
        r.y :=      (2.0*ay +     by) / 3.0;
 
        t.x :=      (    ax + 2.0*bx) / 3.0;
        t.y :=      (    ay + 2.0*by) / 3.0;
 
        middle.x := (    ax +     bx) / 2.0;
        middle.y := (    ay +     by) / 2.0;
 
        xDelta := bx - ax;
        yDelta := by - ay;
 
        s.x := middle.x + factor*yDelta;
        s.y := middle.y - factor*xDelta; 
       
        SetColor (0);
        MoveTo2D (ax, ay);    {blank this line}
        LineTo2D (bx, by);
 
        SetColor (1);
        MoveTo2D (ax, ay);    {add new lines}
        LineTo2D (r.x, r.y);
        LineTo2D (s.x, s.y);
        LineTo2D (t.x, t.y);
        LineTo2D (bx, by);
 
        NextSegments (ax,ay,r.x,r.y, n-1);
        NextSegments (r.x,r.y,s.x,s.y, n-1);
        NextSegments (s.x,s.y,t.x,t.y, n-1);
        NextSegments (t.x,t.y,bx,by, n-1);
      END
      
    END {NextSegments};
 
 
 
    PROCEDURE KochSnowflake (a,b,c:  FPoint; n:  byte);
    BEGIN
 
      SetColor (1);
      MoveTo2D (a.x, a.y);
      LineTo2D (b.x, b.y);
      NextSegments (a.x, a.y, b.x, b.y, n);
 
      MoveTo2D (b.x, b.y);
      LineTo2D (c.x, c.y);
      NextSegments (b.x, b.y, c.x, c.y, n);
 
      MoveTo2D (c.x, c.y);
      LineTo2D (a.x, a.y);
      NextSegments (c.x, c.y, a.x, a.y, n);
      
    END {KochSnowflake};
 
 
  PROCEDURE CreateKochSnowflake;
    VAR
      a,b,c :  FPoint;
      loop  :  byte;
 
  BEGIN
 
    a.x := -ray0;
    a.y := -ray1*SQRT(3.0);
 
    b.x := ray0;
    b.y := -ray1*SQRT(3.0);
 
    c.x :=  0.0;
    c.y :=  ray1*SQRT(3.0);
   
    KochSnowflake (a,b,c, iteration);
    
  END {CreateKochSnowflake};
 
 
BEGIN
 
 gd := D8bit;
 gm := m640x480;
 
 InitGraph(gd,gm,'');
 
 CreateKochSnowflake;
 
 repeat until keypressed;
 
END.

post-4486-0-16288100-1473337707_thumb.png

koch_snowflake.zip

  • Like 3
Link to comment
Share on other sites

  • 1 month later...
  • 2 weeks later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...
  • Recently Browsing   0 members

    • No registered users viewing this page.
×
×
  • Create New...