+Stephen Posted July 5, 2016 Share Posted July 5, 2016 I loved R.O.T.O. Cool to see this version. I will be studying the code, surprised how small it is. Quote Link to comment Share on other sites More sharing options...
pps Posted July 8, 2016 Share Posted July 8, 2016 (edited) 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 {--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 July 8, 2016 by pps Quote Link to comment Share on other sites More sharing options...
pps Posted July 8, 2016 Share Posted July 8, 2016 (edited) 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 {--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 July 8, 2016 by pps Quote Link to comment Share on other sites More sharing options...
tebe Posted July 9, 2016 Share Posted July 9, 2016 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 Quote Link to comment Share on other sites More sharing options...
tebe Posted July 10, 2016 Share Posted July 10, 2016 (edited) // 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 July 10, 2016 by tebe Quote Link to comment Share on other sites More sharing options...
tebe Posted July 10, 2016 Share Posted July 10, 2016 (edited) // 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 July 10, 2016 by tebe Quote Link to comment Share on other sites More sharing options...
pps Posted July 11, 2016 Share Posted July 11, 2016 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). Quote Link to comment Share on other sites More sharing options...
tebe Posted July 12, 2016 Share Posted July 12, 2016 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. 2 Quote Link to comment Share on other sites More sharing options...
tebe Posted July 16, 2016 Share Posted July 16, 2016 Skyscrapers http://atarionline.pl/forum/comments.php?DiscussionID=3797&page=1 Mad Pascal version by Pirx skyscrapers.zip 2 Quote Link to comment Share on other sites More sharing options...
pirx Posted July 17, 2016 Share Posted July 17, 2016 (edited) an improved version, better than BASIC original. sky_pas2.zip Edited July 17, 2016 by pirx 1 Quote Link to comment Share on other sites More sharing options...
tebe Posted July 25, 2016 Share Posted July 25, 2016 (edited) ClipLine, SetClipRect (unit FASTGRAPH) Cube_ClipLine.zip Edited July 25, 2016 by tebe 2 Quote Link to comment Share on other sites More sharing options...
pirx Posted July 26, 2016 Share Posted July 26, 2016 WHOA!!! Quote Link to comment Share on other sites More sharing options...
danwinslow Posted July 26, 2016 Share Posted July 26, 2016 Wow this is looking good. Quote Link to comment Share on other sites More sharing options...
Gury Posted July 27, 2016 Author Share Posted July 27, 2016 Quote Link to comment Share on other sites More sharing options...
tebe Posted August 7, 2016 Share Posted August 7, 2016 MP 1.4.2 new real type SINGLE, faster then REAL compare: cube_clip2.obx (REAL), cube_clip3.obx (SINGLE) cube_single.zip 2 Quote Link to comment Share on other sites More sharing options...
Gury Posted August 8, 2016 Author Share Posted August 8, 2016 I thought I pressed F1 for speed in emulator Well done! It is quite impressive what can be done with small updates, in this example with smaller real type, removing some code and memory overhead. Quote Link to comment Share on other sites More sharing options...
ascrnet Posted August 10, 2016 Share Posted August 10, 2016 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 Quote Link to comment Share on other sites More sharing options...
tebe Posted August 21, 2016 Share Posted August 21, 2016 (* 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 2 Quote Link to comment Share on other sites More sharing options...
+MrFish Posted August 21, 2016 Share Posted August 21, 2016 I'm getting this error when I eliminate the first row on the left and part of the second row: BTW, this is much more playable on PAL; it's a little too fast on NTSC. Quote Link to comment Share on other sites More sharing options...
tebe Posted August 24, 2016 Share Posted August 24, 2016 I'm getting this error when I eliminate the first row on the left and part of the second row: invaders error.png BTW, this is much more playable on PAL; it's a little too fast on NTSC. invaders proper version invaders_proper.zip 1 Quote Link to comment Share on other sites More sharing options...
+MrFish Posted August 24, 2016 Share Posted August 24, 2016 (edited) The last guy doesn't go fast enough, though. He should be skipping some space in horizontal movement. Probably the last few guys should be skipping a little too. Edited August 24, 2016 by MrFish Quote Link to comment Share on other sites More sharing options...
tebe Posted September 5, 2016 Share Posted September 5, 2016 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 1 Quote Link to comment Share on other sites More sharing options...
tebe Posted September 8, 2016 Share Posted September 8, 2016 // 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. koch_snowflake.zip 3 Quote Link to comment Share on other sites More sharing options...
funkheld Posted November 2, 2016 Share Posted November 2, 2016 Hi good afternoon. With which graphics program for the pc can one produce the format MIC? thank you greeting Quote Link to comment Share on other sites More sharing options...
tebe Posted November 14, 2016 Share Posted November 14, 2016 G2F (CTRL+M) Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.