Jump to content

Photo

Mad Pascal examples


76 replies to this topic

#1 Gury OFFLINE  

Gury

    Stargunner

  • 1,197 posts

Posted Sun Oct 11, 2015 4:49 PM

Put some examples here.

 

Character set redefinition example:

rnd_chars.png

{
  Mad Pascal example:
  Character set redefinition
}
uses crt, graph;

var
  n : byte;
  topMem : word;
  RAMTOP : byte absolute $6A;
  //CHBAS : byte absolute $2F4;

  // Data for new characters
  _CHECK : array[0..7] of byte = (0, 1, 3, 6, 140, 216, 112, 32);
  _SMILEY : array[0..7] of byte = (60, 66, 165, 129, 165, 153, 66, 60);
  
begin
  InitGraph(0);

  // Reserve memory for new character set
  topMem := RAMTOP - 8;
  topMem := topMem * 256;

  // New page address for new set
  //CHBAS := topmem div 256;
  Poke($2F4, 184);

  // Copy Atari characters
  move(pointer(57344), pointer(topMem), 1023);

  // Redefine some characters
  move(_SMILEY, pointer(topMem+28*8), 8);
  move(_CHECK, pointer(topMem+30*8), 8);

  // Go wild
  repeat
    GotoXY(Random(39), Random(24));
    n := Random(60);
    if n < 30 then
      Write('<')
    else
      Write('>');
  until 0;
end.

I commented CHBAS code, because I didn't know how to make it work that way.

 

Attached Files



#2 Gury OFFLINE  

Gury

    Stargunner

  • Topic Starter
  • 1,197 posts

Posted Fri Oct 16, 2015 4:21 PM

I present you Color Picker, which can be useful for selecting colors for background, border, text and player/missile graphics. Program shows current color values in decimal and hexadecimal notation. It can help you experimenting with different colors/values for your program. The program and its source code are available below this post.

 

Program control:

- Arrow keys Right/Left: Incrementing/decrementing color value by 2

- Arrow keys Up/Down: Incrementing/decrementing color value by 10

- Joystick (same function as with arrow keys)

- D: Default values (note that default values in this case mean specific color values for this program, not the ones on Atari power-up)

- Select console key: Selection of color memory location

 

cp.png

{
  Color Picker by Bostjan Gorisek
  16.10.2015
}
uses crt, dos, pmg, graph, sysutils;

var
  i : Byte;
  y : Byte = 3;
  stop: Boolean;
  stick : byte absolute $278;
  // Memory location map
  pcol : array[0..6] of word = ($2C6, $2C8, $2C5, $02C0, $02C1, $02C2, $02C3);

  // Player data
  p0Data : array [0.._P_MAX] of byte = (255, 255, 255, 255, 255, 255, 255, 255, 255, 0, 0, 0, 0, 0, 0);
  p1Data : array [0.._P_MAX] of byte = (255, 255, 255, 255, 255, 255, 255, 255, 255, 0, 0, 0, 0, 0, 0);
  p2Data : array [0.._P_MAX] of byte = (255, 255, 255, 255, 255, 255, 255, 255, 255, 0, 0, 0, 0, 0, 0);
  p3Data : array [0.._P_MAX] of byte = (255, 255, 255, 255, 255, 255, 255, 255, 255, 0, 0, 0, 0, 0, 0);
  
  // Selected color memory location
  CurrPlyr : byte = 0;

procedure SetColors;
begin
  poke(pcol[0], 0);   // Background color
  poke(pcol[1], 160);  // Border color
  poke(pcol[2], 10);  // Text color
  poke(pcol[3], 50);  // Player 0 color
  poke(pcol[4], 134);  // Player 1 color
  poke(pcol[5], 164);  // Player 2 color
  poke(pcol[6], 232);  // Player 3 color
  GotoXY(3, y);     Write('Background  710 $2C6  dec:', peek(pcol[0]), ' hex:', IntToHex(peek(pcol[0]), 0));
  GotoXY(3, y+3);   Write('Border      712 $2C8  dec:', peek(pcol[1]), ' hex:', IntToHex(peek(pcol[1]), 0));
  GotoXY(3, y+3*2); Write('Text        709 $2C5  dec:', peek(pcol[2]), ' hex:', IntToHex(peek(pcol[2]), 0));
  GotoXY(6, y+3*3); Write('Player 0 704 $02C0 dec:', peek(pcol[3]), ' hex:', IntToHex(peek(pcol[3]), 0));
  GotoXY(6, y+3*4); Write('Player 1 705 $02C1 dec:', peek(pcol[4]), ' hex:', IntToHex(peek(pcol[4]), 0));
  GotoXY(6, y+3*5); Write('Player 2 706 $02C2 dec:', peek(pcol[5]), ' hex:', IntToHex(peek(pcol[5]), 0));
  GotoXY(6, y+3*6); Write('Player 3 707 $02C3 dec:', peek(pcol[6]), ' hex:', IntToHex(peek(pcol[6]), 0));
end;
  
Procedure KeyScan;
var
  ch : char;
  n : byte;
begin
  If KeyPressed or (stick <> 15) then begin    
    if Keypressed then
      ch := UpCase(ReadKey)
    else begin
      if stick = 14 then ch := #28
      else if stick = 13 then ch := #29
      else if stick = 11 then ch := #30
      else if stick = 7 then ch := #31;
      Delay(160);
    end;
    n := Peek(pcol[CurrPlyr]);    
	  if (ch = #28) then begin  {up}
      Inc(n, 10);
      Poke(pcol[CurrPlyr], n);
    end else if (ch = #29) then begin  {down}
      Dec(n, 10);
      Poke(pcol[CurrPlyr], n);
    end else if (ch = #30) then begin   {left}
      Dec(n, 2);
      Poke(pcol[CurrPlyr], n);
    end else if (ch = #31) then begin   {right}
      Inc(n, 2);
      Poke(pcol[CurrPlyr], n);
    end else if ch = #68 then begin
      SetColors;
    end;
    n := Peek(pcol[CurrPlyr]);
    GotoXY(25, y+3*(CurrPlyr));
    Write('dec:', n, ' hex:', IntToHex(n, 0), ' ');
  end
end;

procedure SetCursor;
begin
  if CurrPlyr = 0 then
    GotoXY(1, y+3*6)
  else begin
    GotoXY(1, y+3*(CurrPlyr-1))
  end;
  Write('  ');
  GotoXY(1, y+3*CurrPlyr);
  Write('=>');
end;

procedure ConsoleKeys;
var
  CONSOL : byte absolute $D01F;
begin
  if CONSOL = 5 then begin
    Inc(CurrPlyr);
    if CurrPlyr = 7 then
      CurrPlyr := 0
    else if CurrPlyr = 0 then begin
      CurrPlyr := 6;
    end;
    SetCursor;
    Delay(400);
  end;
end;

procedure SetupPM;
begin
  // Initialize P/M custom variables
  p_data[0] := @p0Data;
  p_data[1] := @p1Data;
  p_data[2] := @p2Data;
  p_data[3] := @p3Data;

  // Initialize P/M graphics
  SetPM(_PM_DOUBLE_RES);
  InitPM(_PM_DOUBLE_RES); 

  // Turn on P/M graphics
  ShowPM(_PM_SHOW_ON);

  // Set player sizes
  SizeP(0, _PM_NORMAL_SIZE);
  SizeP(1, _PM_NORMAL_SIZE);
  SizeP(2, _PM_NORMAL_SIZE);
  SizeP(3, _PM_NORMAL_SIZE);
  
  // Position and show players
  MoveP(0, 57, 57);
  MoveP(1, 57, 69);
  MoveP(2, 57, 81);
  MoveP(3, 57, 93);
end;

// Inverse text
procedure InvText(str : string);
var
  i : Byte;
begin
  for i := 1 to Length(str) do begin
    str[i] := Chr(Ord(str[i]) + $80);
  end;
  write(str);
end;

procedure SetText;
begin
  GotoXY(14,0); InvText('Color Picker');
  SetColors;
  GotoXY(1, 23); InvText(' Select '); Write(' Select color location');
  GotoXY(1, 24); InvText(' D '); Write(' Default colors');
  Write('  ', Chr(160), Chr(27), Chr(156), Chr(27), Chr(157), Chr(27), Chr(158), Chr(27), Chr(159), Chr(160));
  Write(' Select color')
end;

begin
  InitGraph(0); CursorOff;
  SetupPM;  
  SetText; SetCursor;  
  // Main loop
  repeat
    ConsoleKeys;
  	KeyScan;
  until 0;
  // Reset P/M graphics
  ShowPM(_PM_SHOW_OFF);
end.

Attached Files

  • Attached File  cp.xex   7.16KB   145 downloads
  • Attached File  pmgcol.zip   52.44KB   106 downloads

Edited by Gury, Fri Oct 16, 2015 4:29 PM.


#3 pps OFFLINE  

pps

    Dragonstomper

  • 765 posts
  • Location:Berlin, Germany

Posted Tue Oct 20, 2015 10:31 AM

Gury, nice idea to have this thread. I will add something here in (near?) future, too.



#4 Gury OFFLINE  

Gury

    Stargunner

  • Topic Starter
  • 1,197 posts

Posted Wed Oct 21, 2015 4:13 AM

:thumbsup:  You are welcome!



#5 Gury OFFLINE  

Gury

    Stargunner

  • Topic Starter
  • 1,197 posts

Posted Thu Oct 22, 2015 12:20 AM

3D Starfield by Thomas Havemeister, published on 07 Mar 2002 (source: https://github.com/spicyjack/Atari-8bit/blob/master/examples/starfield_demo.txt). Assembler code can be compiled with Atasm and should be compatible with MAC/65. Ported to Mad Pascal with nearly no effort. Binary file is attached below.

 

3dsf.png

{
  Program       : 3D Starfield by Thomas Havemeister (converted to Mad Pascal)
  Original date : 07 Mar 2002
  Source        : https://github.com/spicyjack/Atari-8bit/blob/master/examples/starfield_demo.txt
}
uses crt, graph;
  
procedure StarField;
begin
asm {
  stx @sp

; ----------------------------------------------------
; constants
; ----------------------------------------------------

VDSLST	= $0200		; vector display list
SDLSTL  = $0230		; shadow register that points to dl
VVBLKI	= $0222		; VBI vector
COLOR2  = $02c6		; shadow register color2
COLOR4  = $02c8		; shadow register color4
HPOSM3	= $d007		; horizontal position of missile3
GRAFM	= $d011		; register for missiles
COLPM3	= $d015		; color register for for missile3
COLPF2	= $d018		; color register playfield2
COLBK	= $d01a		; background color
NMIEN	= $d40e		; VBI switch
RANDOM	= $d20a		; (r) gets a random number
WSYNC	= $d40a		; (w) stops cpu for a vertical synchronisation
SYSVBV	= $e45f		; jump to OS VBI

; ----------------------------------------------------
; variables
; ----------------------------------------------------

starfield  = $5000	; array of random stars 
speed	   = $5100      ; array of speed for each star
colors	   = $5200	; array of color for each star

; ----------------------------------------------------
; segment: main program
; ----------------------------------------------------
	
	*= $4000

Start	lda #0			
	sta NMIEN		; disable VBI's/DLI's
	sta COLPF2		; set colors to black
	sta COLBK
	sta COLOR2
	sta COLOR4

;----------------------
	lda #<DLI		; register new DLI subroutine
	sta VDSLST
	lda #>DLI
	sta VDSLST+1

	lda #<VBI		; register new VBI subroutine
	sta VVBLKI
	lda #>VBI
	sta VVBLKI+1

;----------------------
	ldx #10			; prepare a loop for each line
Setup	lda RANDOM		; load a random byte
	sta starfield,x		; and save it as a new star position
	
	lda RANDOM              ; load another random byte
	and #$3                 ; generate some speed informations
	sta speed,x		; and save them
	inc speed,x
	
	lda RANDOM		; at last save color information
	sta colors,x		; and make it looking atari

	inx			; repeat it, until all lines are done
	bne Setup		

; ---------------------
	lda SDLSTL		; save the dl-program adress
	sta $0			; into page zero
	lda SDLSTL+1
	sta $1

	ldy #2			; and adjust the existing progamm
	lda #$f0		; with command "$f0"
	sta ($0),y		

; ---------------------
	lda #$c0		; enable VBI's/DLI's
	sta NMIEN

Loop	nop			; do what you like
	jmp Loop		; endless loop

; ----------------------------------------------------
; DLI subroutine
;
; this is the tricky part of the starfield
; normaly, a long blocky missile should be drawn
; but DLI changes in each line the position and behaviour
; ----------------------------------------------------

DLI	pha                     ; save the registers to stack
	tya
	pha

	lda #$80                ; draw a star in missile register
	sta GRAFM		; (writes bit 7 in missile 3)

	ldy #$d0		; prepare a loop
Setstar lda starfield-1,y	
	sta WSYNC		; wait for synchronize
	sta HPOSM3		; 'paint the new' star
	lda colors-1,y		
	sta COLPM3		; and change the color
	dey
	bne Setstar		; repeat it for every single line
	pla
	tay
	pla
	rti

; ----------------------------------------------------
; VBI subroutine
; 
; here we calculate the 3d type fx and the new star 
; positons. this is just changing the arrays on 
; every vertical blank interrupt
; ----------------------------------------------------

VBI	ldy #0
Move	lda starfield,y
	clc
	adc speed,y
	sta starfield,y
	dey
	bne Move
	jmp SYSVBV

; ---------------------------------
; segment: dos loader
; ---------------------------------

	*=  $02E0
	.word Start
  
  ldx @sp
  };
end;

begin
  InitGraph(0); CursorOff;
  gotoxy(4, 5); writeln('3D Starfield by Thomas Havemeister');
  gotoxy(4, 6); writeln('Original date: 07 Mar 2002');
  gotoxy(4, 7); writeln('Converted to Mad Pascal');
  StarField;                       
end.
 

Maybe there should be some changes, but it works as expected already.

 

Attached Files


Edited by Gury, Thu Oct 22, 2015 12:31 AM.


#6 pps OFFLINE  

pps

    Dragonstomper

  • 765 posts
  • Location:Berlin, Germany

Posted Fri Oct 23, 2015 2:14 PM

Ok, here we go with another example ;)

 

Have fun with this little Mandelbrot with MADPascal based on my code on ATARI ST PurePascal I wrote around 1995.

 

Enjoy "pure Pascal code" - the floating points seems to have only 2 digits, so don't expect to deep computes.

Rewriting this was a bit tricky, as 'if a>b then' does have some issues with floating point numbers. -> @TeBe: some work for you ;)

program fraktal;

//rework from original PurePascal programme I wrote 1995

uses graph,crt,sysutils;


var jn:char;
    mx:BYTE;
    c1,c2,xd,yd,xmax,ymax,xmin,ymin:REAL;
    xin,yin:STRING;
	
procedure apfel(add,iter:byte);

var z3,z4,z5,z1,z2,ze1,ze2:real;
    raus,xpkt,ypkt,i:byte;

begin
 ypkt:=1;
 repeat 
  xpkt:=1;
  repeat 
   z1:=0.0;
   z2:=0.0;
   i:=0;
   raus:=0;
   repeat
    ze1:=(z1*z1)-(z2*z2)+c1;
    ze2:=(2.0*z1*z2)+c2;
    inc(i);
    z1:=ze1;
    z2:=ze2;
    z3:=z1*z1;
    z4:=z2*z2;
    z5:=z3+z4;
    setcolor(i);
    putpixel(xpkt,ypkt);
    poke(77,0);
    if z5 > 4.0 then raus:=1
      else if i > iter then raus:=1;
   until raus=1;
   if i > iter then SetColor(0)
     else begin
     	SetColor((i mod 3)+1)
     end;
   PutPixel(xpkt,ypkt);
   if add = 2 then PutPixel(xpkt+1,ypkt+1);
   c1:=c1+xd;
   xpkt:=xpkt+add;
  until xpkt>160;
  c1:=xmin;
  c2:=c2-yd;
  ypkt:=ypkt+add;
 until ypkt>96;
 i:=0;
 repeat
 setbkcolor(i);
  inc(i);
  delay(2);
 until i=255;
 setbkcolor(0);
end;

procedure vorschau;
var r1,r2,z3,z4,z5:real;

begin

 InitGraph(7);
 yd:=(ymax-ymin)/48.0;
 xd:=(xmax-xmin)/80.0;
 c1:=xmin;
 c2:=ymax;
 apfel(2,7);
 repeat until keypressed;

end;



begin
 initgraph(0);
 writeln('************************************');
 writeln('*  Mandelbrot for MADPascal with   *');
 writeln('*    preview, based on an old      *');
 writeln('*PurePascal programme, I did for ST*');
 writeln('***************************PPs 2015*');
 writeln;
 write('XMIN (-2): ');
 readln(xin);
 xmin:=StrToFloat(xin);
 write('XMAX  (2): ');
 readln(xin);
 xmax:=StrToFloat(xin);
 write('YMIN (-2): ');
 readln(yin);
 ymin:=StrToFloat(yin);
 write('YMAX  (2): ');
 readln(yin);
 ymax:=StrToFloat(yin);
 write('Preview (iteration is 7) (y/n): ');
 readln(jn);
 if (jn='y') or (jn='Y') then begin
  vorschau;
  clrscr;
 end;
 poke(764,255);
 write('Really compute (y/n): ');
 readln(jn);
 if (jn='y') or (jn='Y') then begin
   write('Iteration: ');
   readln(xin);
   mx:=strtoint(xin);
   initgraph(7);  
   yd:=(ymax-ymin)/96.0;
   xd:=(xmax-xmin)/160.0;
   c1:=xmin;
   c2:=ymax;
   apfel(1,mx);
   repeat until keypressed;
 end;

end.

Attached File  Fraktal.zip   4.4KB   153 downloads



#7 tebe OFFLINE  

tebe

    Dragonstomper

  • 628 posts
  • Location:Poznań - Poland

Posted Sat Oct 24, 2015 12:54 AM

yes, Float Point will be changed



#8 Gury OFFLINE  

Gury

    Stargunner

  • Topic Starter
  • 1,197 posts

Posted Fri Nov 13, 2015 11:32 AM

Here is an example of using file I/O functions in Mad Pascal. This program instantly shows Micro Illustrator file on the screen, really very FAST. The program on disk is called pic3.xex, with other two examples showing the same result, but with slower performance because of different programming techniques used.

 

pic.png

{------------------------------------------------------------------------------
  Reading Micro Illustrator file and showing it on the screen
  Example 3: Fast solution
------------------------------------------------------------------------------}
uses graph;

var
  f : file;        // File pointer
  s : string[15];  // Filename storage
  scr : word absolute 88;         // Screen display
  buf : array [0..7679] of byte;  // Picture data storage

begin
  InitGraph(15);
  s := 'D:CLOUDS.MIC';
  assign(f, s);
  reset(f, sizeof(buf));  
  blockread(f, buf, 1);
  move(pointer(buf), pointer(scr), sizeof(buf));
  close(f);        
  repeat until 1 = 0;
end.

Attached are ATR disk (DOS 2 single density) for using with any Atari emulator or real machine. Archived zipped file contains all source code, executable files, batch file, picture and ATR image together. When extracted, all files have to be put in MadPascal folder with same structure of zipped file if you want to compile it yourself.

 

Attached Files

  • Attached File  pic.atr   90.02KB   138 downloads
  • Attached File  pic.zip   37.61KB   130 downloads


#9 rdea6 OFFLINE  

rdea6

    River Patroller

  • 2,515 posts
  • Location:Arizona USA

Posted Fri Nov 13, 2015 3:30 PM

Attached File  clouds.mic.txt   7.5KB   123 downloads

 

Here an alternate MIC file for you JUST take the txt extender off.

 

Also a nice exit to DOS would be so COOL.

 



#10 tebe OFFLINE  

tebe

    Dragonstomper

  • 628 posts
  • Location:Poznań - Poland

Posted Sun Nov 15, 2015 10:55 AM

uses crt, graph;
 
var
  f : file;        // File pointer
  s : string[15];  // Filename storage
  buf: ^byte;
 
begin
InitGraph(15);
s := 'D:CLOUDS.MIC';
 
assign(f, s);
reset(f, 1);
 
buf:=pointer(dpeek(88));
  
blockread(f, buf, 7680);
 
buf:=pointer(712);
blockread(f, buf, 1);
 
buf:=pointer(708);
blockread(f, buf, 3);
 
close(f);
 
repeat until keypressed;
end.


#11 pps OFFLINE  

pps

    Dragonstomper

  • 765 posts
  • Location:Berlin, Germany

Posted Fri Jun 3, 2016 1:09 PM

Had a short go with the intr command to do some vbl and dli and set up a custom display list.

 

It's dirty code, but I hope you can use it to understand how to set up a custom dl and get some DLI and VBI running. Some of the code is borrowed...

screen.png

uses crt, rmt;

const
	rmt_player = $a000;
	rmt_modul = $4000;

var
	msx: TRMT;
	ntsc: byte;
	palntsc: byte absolute $d014;
		
{$r 'rmt_play.rc'}

procedure vbl_PAL; interrupt;
begin
 RMTplay(msx);
asm
{
	jmp xitvbv
};
end;

procedure vbl_ntsc; interrupt;
begin

	if ntsc=6 then
	 ntsc:=0
	else
	 RMTplay(msx);

	inc(ntsc);

asm
{	jmp xitvbv
};
end;

procedure vbl_empty; interrupt;
begin
asm
{
	jmp xitvbv
};
end;

procedure dli_bs; interrupt;
begin
asm
{
	pha
	txa
	pha
	tya
	pha

	ldx #$0
lp
	stx colbak
	txa
	and #$82
	sta color2
	stx wsync
	inx
	cpx #$e0
	bne lp

	pla
	tay
	pla
	tax
	pla
	rti

};
end;

procedure no_dli; interrupt;
begin

end;

begin
 asm
 {
 bpl we
dl
	dta b($f0,$70,$70,$42,$40,$bc,$40,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$41),a(dl)
we
 mwa #dl 560
 };

 msx.player:=pointer(rmt_player);
 msx.modul:=pointer(rmt_modul);

 RMTinit(msx);

 if palntsc=1 then
  intr(iVBL, @vbl_pal)
 else
  intr(iVBL, @vbl_ntsc);
 intr(iDLI, @dli_bs);

 poke($d40e,$c0);

 writeln('         Lotus II title song       ');
 writeln('quick and dirty dl and dli handling');
 writeln('with MAD Pascal');
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln('NTSC speeds up the song sometimes if');
 writeln('loop to higher than $e0 in DLI');
 writeln('play a bit with AND #$82 in dli to');
 writeln('have some other nice colours');

 repeat

 until keypressed;

 intr(iVBL, @vbl_empty);
 intr(iDLI, @no_dli);
 RMTstop(msx);

end.

Attached File  Lotus_itile_song.zip   7.03KB   88 downloads



#12 pps OFFLINE  

pps

    Dragonstomper

  • 765 posts
  • Location:Berlin, Germany

Posted Sun Jun 5, 2016 2:49 AM

Just noticed, that it produces no sound, when compiled with madpascal 1.34 (even when used mads 2.05b). madpascal 1.33 works fine.

 

EDIT: Seems like the libraries of madpascal are taken over by the compiled programme code in 1.34

screen.png


Edited by pps, Sun Jun 5, 2016 3:07 AM.


#13 tebe OFFLINE  

tebe

    Dragonstomper

  • 628 posts
  • Location:Poznań - Poland

Posted Sun Jun 5, 2016 5:13 AM

use madpascal rmtplayer (\base\rmt_player.asm)

 

file.rc:

rmt_player RMTPLAY 'lotus_title.feat' 1
rmt_modul RMT 'lotus_title.rmt'
 
label rmtplay 'filename.feat' parameter
 
parameter 0..3
0 => compile RMTplayer for 4 tracks mono
1 => compile RMTplayer for 8 tracks stereo
2 => compile RMTplayer for 4 tracks stereo L1 R2 R3 L4
3 => compile RMTplayer for 4 tracks stereo L1 L2 R3 R4    
 

Edited by tebe, Mon Jun 6, 2016 6:26 AM.

  • pps likes this

#14 tebe OFFLINE  

tebe

    Dragonstomper

  • 628 posts
  • Location:Poznań - Poland

Posted Sun Jun 5, 2016 8:43 AM

mads 1.3.5 http://mads.atari8.info

 

read DLI, VBL vector

INTR(rDLI, LABEL);
INTR(rVBL, LABEL);

read constant address

const
 tb: array [0..0] of byte = ( lo(word(@tb)) );
 
\example\lotus_title_song\
uses crt, rmt;
 
const
dl: array [0..32] of byte = (
$f0,$70,$30,$42,$40,$bc,$02,$02,
$02,$02,$02,$02,$02,$02,$02,$02,
$02,$02,$02,$02,$02,$02,$02,$02,
$02,$02,$02,$02,$02,$02,$41,
lo(word(@dl)), hi(word(@dl))
);
 
rmt_player = $a000;
rmt_modul = $4000;
 
var msx: TRMT;
ntsc: byte;
palntsc: byte absolute $d014;
 
old_dli, old_vbl: pointer;
 
 
{$r 'rmt_play.rc'}
 
 
procedure vbl_PAL; interrupt;
begin
 RMTplay(msx);
asm
{
jmp xitvbv
};
end;
 
procedure vbl_ntsc; interrupt;
begin
 
if ntsc=6 then
ntsc:=0
else
RMTplay(msx);
 
inc(ntsc);
 
asm
{ jmp xitvbv
};
end;
 
procedure dli_bs; interrupt;
begin
asm
{ phr
 
ldx #$0
lp
stx colbak
txa
and #$82
sta color2
stx wsync
inx
cpx #$e0
bne lp
 
plr
rti
};
end;
 
 
begin
 
 intr(rDLI, old_dli);
 intr(rVBL, old_vbl);
 
 dpoke(560, word(@dl));
 
 msx.player:=pointer(rmt_player);
 msx.modul:=pointer(rmt_modul);
 
 RMTinit(msx);
 
 if palntsc=1 then
  intr(iVBL, @vbl_pal)
 else
  intr(iVBL, @vbl_ntsc);
 
 intr(iDLI, @dli_bs);
 
 poke($d40e,$c0);
 
 writeln('         Lotus II title song       ');
 writeln('quick and dirty dl and dli handling');
 writeln('with MAD Pascal');
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln('NTSC speeds up the song sometimes if');
 writeln('loop to higher than $e0 in DLI');
 writeln('play a bit with AND #$82 in dli to');
 writeln('have some other nice colours');
 
 repeat
 
 until keypressed;
 
 intr(iVBL, old_vbl);
 intr(iDLI, old_dli);
 
 RMTstop(msx);
 
end.

Edited by tebe, Sun Jun 5, 2016 8:44 AM.


#15 pps OFFLINE  

pps

    Dragonstomper

  • 765 posts
  • Location:Berlin, Germany

Posted Tue Jun 7, 2016 1:43 PM

I got a little further with this example. You can now learn how to show different graphic modes and screen memory locations on one screen and use the write command to fill it with text.

uses crt, rmt;

const
	dl: array [0..33] of byte = (
	$f0,$70,$70,$42,$40,$bc,$40,$02,
	$02,$02,$02,$02,$02,$02,$02,$02,
	$02,$02,$02,$02,$02,$02,$02,$02,
	$02,$02,$02,$02,$02,$02,$02,$41,
	lo(word(@dl)), hi(word(@dl))
	);
	
	dl2: array [0..39] of byte=(
	$70,$70,$70,
// some lines of gfx 0 at $8000
	$42,$00,$80,$70,$70,$70,
	$02,$02,$02,$02,
// gfx 1 & 2 at $9000
	$46,$00,$90,$06,$07,$06,$06,
// back to gfx 0 at line 5
	$42,$C8,$80,$02,$02,$02,
	$70,
// now some gfx 12 stuff at $8400
	$44,$00,$84,$04,$04,$04,
	$70,
// back to last gfx 0 line at $8168
	$42,$68,$81,
	$41,
	lo(word(@dl2)), hi(word(@dl2))
	);

	rmt_player = $a000;
	rmt_modul = $4000;

var	msx: TRMT;
	ntsc: byte;
	palntsc: byte absolute $d014;

	old_dli, old_vbl: pointer;

		
{$r 'rmt_play.rc'}


procedure vbl_PAL; interrupt;
begin
 RMTplay(msx);
asm
{
	jmp xitvbv
};
end;

procedure vbl_ntsc; interrupt;
begin

	if ntsc=6 then
	 ntsc:=0
	else
	 RMTplay(msx);

	inc(ntsc);

asm
{	jmp xitvbv
};
end;

procedure dli_bs; interrupt;
begin
asm
{	phr

	ldx #$0
lp
	stx colbak
	txa
	and #$82
	sta color2
	stx wsync
	inx
	cpx #$e0
	bne lp

	plr
	rti
};
end;


begin

 intr(rDLI, old_dli);
 intr(rVBL, old_vbl);

 dpoke(560, word(@dl));

 msx.player:=pointer(rmt_player);
 msx.modul:=pointer(rmt_modul);

 RMTinit(msx);

 if palntsc=1 then
  intr(iVBL, @vbl_pal)
 else
  intr(iVBL, @vbl_ntsc);

 intr(iDLI, @dli_bs);

 poke($d40e,$c0);

 writeln('   RMT-DL-VBL-DLI with MAD Pascal  ');
 writeln('NTSC / PAL detect for correct music');
 writeln('playback');
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln('You can put text to screen simple');
 writeln('write / writeln commands of Pascal');
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 writeln;
 write('-----------press a key ------------');

 repeat

 until keypressed;

 intr(iVBL, old_vbl);
 intr(iDLI, old_dli);

 RMTstop(msx);

 readkey;

 dpoke(560, word(@dl2));

// set screen area and clear it
 dpoke(88,$8000);
 clrscr;

 writeln('0 -      different gfx modes        ');
 writeln('1 - ten lines of gfx 0 at $8000');
 writeln('2 - inherit by some lines with');
 writeln('3 - gfx 1 & 2 on different screen');
 writeln('4 - memory area');
 writeln('5 - ($9000 here)');
 writeln('6 - first gfx0 write then');
 writeln('7 - change 88 to write gfx 1 & 2');
 writeln('8 - then same for writing gfx 12');
 writeln('9 - neat, isnt it?');

// now change the screen area
 dpoke(88,$9000);

// BASIC: POSITION(2,0)
 dpoke(85,2);
 poke(84,0);

// write don't know about the shorter lines of gfx 1 and 2 (changing RMARGN does not help here)
 write('   HEre We GO       ');
 write('   HEre We GO     ');
 write(' !!HEre We GO!!     ');
 write('   HEre We GO     ');
 write('   HEre We GO     ');

// gfx 12 stuff now
 dpoke(88,$8400);
 dpoke(85,2);
 poke(84,0);

 writeln('------------------------------------');
 writeln('     gfx 12 is hard to read :)');
 writeln('     better use a special font');
 writeln('-------------KEY--EXITS-------------');

 repeat

 until keypressed;

end.

Attached File  gfx_example.zip   6.7KB   121 downloads



#16 tebe OFFLINE  

tebe

    Dragonstomper

  • 628 posts
  • Location:Poznań - Poland

Posted Tue Jun 7, 2016 2:22 PM

thx PPS :)

 

another example from https://blog.greblus...-w-madpascal-u/

 

// DLI Scroll by Greblus
 
uses crt;
 
const
dl: array [0..32] of byte = 
(
112, 112, 112, 66, 0, 64, 2, 2, 2, 2, 2, 2, 2, 2, 2, 
2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 130, 86, 36, 67, 65, 
lo(word(@dl)), hi(word(@dl))
);
 
var
col0: byte absolute 708;
col1: byte absolute 709;
savmsc: cardinal absolute 88;
nmien: byte absolute $d40e;
pc: ^byte; 
tmp: word; 
hscrol: byte absolute 54276;
vcount: byte absolute $d40b;
colt: byte absolute $d017;
wsync: byte absolute $d40a;
dlist: cardinal absolute 560;
i,j,k,l,indx: byte;
 
procedure dli; interrupt; 
begin
 asm { phr };
 inc(indx);
 for i:=0 to 7 do
  begin
   wsync:=1;
   if indx>30 then indx:=0;
   colt:=vcount+indx;
  end;
 asm { plr \ rti };
end;
  
procedure scroll; interrupt;
begin
 hscrol:=j;
 j:=j+1;
 if j=17 then
  begin
   j:=0; dec(pc^,2); k:=k+1;
   if k=14 then
    begin
     k:=0; pc^:=tmp;
    end
  end;
 asm { jmp $E462 }; 
end;
 
begin
 i:=0; j:=0; k:=0; indx:=0;
 dlist:=word(@dl);
  
 intr(iVBL, @scroll);
 intr(iDLI, @dli);
 nmien:=$c0;
 
 pc := @dl;
 inc(pc, 28);
 
 tmp := pc^+6; 
 col0 := 14; col1 := 14;
 savmsc := $4000;
 
 for l:=1 to 22 do
  writeln(' mp rulez! ');
 
 repeat until keypressed;
 
end.

Attached Files



#17 Gury OFFLINE  

Gury

    Stargunner

  • Topic Starter
  • 1,197 posts

Posted Wed Jun 8, 2016 1:54 AM

I got a little further with this example. You can now learn how to show different graphic modes and screen memory locations on one screen and use the write command to fill it with text.

attachicon.gifgfx_example.zip

 

Very good example on interrupts, thank you very much. Finally I know how to use intr function for DLIs and VBI.



#18 Gury OFFLINE  

Gury

    Stargunner

  • Topic Starter
  • 1,197 posts

Posted Wed Jun 8, 2016 6:50 AM

 

thx PPS :)

 

another example from https://blog.greblus...-w-madpascal-u/

// DLI Scroll by Greblus

 

Very neat! From original Action! example... Mad Pascal shows its strength in speed, code structure and simple use of assembler mnemonic commands, similar to Action! language, but easier.



#19 greblus OFFLINE  

greblus

    Chopper Commander

  • 249 posts

Posted Wed Jun 8, 2016 7:11 AM

Yeah, but still: Action! syntax is more concise and easier to read/write.



#20 Xuel OFFLINE  

Xuel

    Dragonstomper

  • 600 posts
  • Location:US

Posted Wed Jun 8, 2016 11:12 AM

procedure scroll; interrupt;
begin
 hscrol:=j;
 j:=j+1;
 if j=17 then
  begin
   j:=0; dec(pc^,2); k:=k+1;
   if k=14 then
    begin
     k:=0; pc^:=tmp;
    end
  end;
 asm { jmp $E462 }; 
end;


You can make the scrolling smoother as follows:
 
procedure scroll; interrupt;
begin
 j:=j+1;
 // Compare j to 16 instead of 17:
 if j=16 then
  begin
   j:=0; dec(pc^,2); k:=k+1;
   if k=14 then
    begin
     k:=0; pc^:=tmp;
    end
  end;
 // Update hscrol after j and pc computation:
 hscrol:=j;
 asm { jmp $E462 }; 
end;


#21 pps OFFLINE  

pps

    Dragonstomper

  • 765 posts
  • Location:Berlin, Germany

Posted Thu Jun 9, 2016 7:30 AM

Now let's go for some hscroll coding ;)

uses crt;

const
 stext = $8000;

 dl	:array [0..29] of byte =(
 $70,$7,$70,$70,$70,$f0,
 $56,$00,$90,$40,$42,$40,$90,
 $2,$2,$2,$2,$2,$2,$2,$2,$2,$2,
 $40,$56,$00,$90,
 $41,lo(word(@dl)), hi(word(@dl))
 );

var
 x,z	: byte;
 count	: byte;
 madr	: word;
 wsync 	: byte absolute $D40A;
 dmactl : byte absolute $d400;
 nmien	: byte absolute $d40e;
 hscrol : byte absolute $D404;
 colpf0 : byte absolute $D016;
 colpf1 : byte absolute $D017;
 colpf2 : byte absolute $D018;
 colpf3 : byte absolute $D019;
 attract: byte absolute 77;
 old_dli, old_vbl: pointer;

{$r scroll.rc}

procedure dli; interrupt;

begin
 asm
 { phr };

 dmactl:=63;
 colpf0:=$da;
 colpf1:=$55;
 colpf2:=$e;
 colpf3:=$88;
 wsync:=1;
 attract:=0;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 colpf2:=$35;
 colpf1:=$e;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 dmactl:=62;
 for z:=0 to 85 do
   wsync:=1;
 dmactl:=63;
 colpf0:=$da;
 colpf1:=$55;
 colpf2:=$e;
 wsync:=1;
 colpf3:=$88;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 colpf2:=$35;
 colpf1:=$e;
 wsync:=1;

 asm
 { plr / rti };
end;

procedure vbi; interrupt;

var
 addr	: word;
 addr2	: word;

begin
 if count=0 then begin
  count:=8;
  x:=0;
  repeat
   addr:=$9000+x;
   addr2:=addr+1;
   poke(addr,peek(addr2));
   inc(x);
  until x=22;
  poke(addr2,peek(madr));
  madr:=madr+1;
  if peek(madr)=$ff then
    madr:=$8000;
 end;
 dec(count);
 hscrol:=count;

asm
{ jmp xitvbv };
end;

begin
 intr(rDLI, old_dli);
 intr(rVBL, old_vbl);

 count:=8;
 madr:=$8000;
 dpoke(560,word(@dl));
 dpoke(88,$9040);
 nmien:=$c0;
 intr(iVBL,@vbi);
 intr(iDLI,@dli);

 writeln('  <---Hscroll with MadPascal--->');
 gotoxy(15,11);
 write('press key');
 repeat

 until keypressed;

 intr(iVBL, old_vbl);
 intr(iDLI, old_dli);

end.

Attached File  scroll.zip   2.18KB   90 downloads


Edited by pps, Thu Jun 9, 2016 7:33 AM.


#22 tebe OFFLINE  

tebe

    Dragonstomper

  • 628 posts
  • Location:Poznań - Poland

Posted Sun Jun 19, 2016 6:46 AM

uses crt;
 
const
 stext = $8000;
 scrol = $9000;
 mtext = $9040;
 
 dl :array [0..29] of byte =(
 $70,$70,$70,$70,$70,
 $f0,$56,lo(scrol),hi(scrol),
 $40,$42,lo(mtext), hi(mtext),
 $2,$2,$2,$2,$2,$2,$2,$2,$2,$2,
 $40,$56,lo(scrol),hi(scrol),
 $41,lo(word(@dl)), hi(word(@dl))
 );
 
var
 ptext : ^byte;
 
 x,z : byte;
 count : byte;
 wsync  : byte absolute $D40A;
 dmactl : byte absolute $d400;
 nmien : byte absolute $d40e;
 hscrol : byte absolute $D404;
 colpf0 : byte absolute $D016;
 colpf1 : byte absolute $D017;
 colpf2 : byte absolute $D018;
 colpf3 : byte absolute $D019;
 attract: byte absolute 77;
 old_dli, old_vbl: pointer;
 
{$r scroll.rc}
 
procedure dli; interrupt;
begin
 asm { phr };
 
 dmactl:=63;
 colpf0:=$da;
 colpf1:=$55;
 colpf2:=$e;
 colpf3:=$88;
 wsync:=1;
 attract:=0;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 colpf2:=$35;
 colpf1:=$e;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 dmactl:=62;
 for z:=0 to 85 do wsync:=1;
 dmactl:=63;
 colpf0:=$da;
 colpf1:=$55;
 colpf2:=$e;
 wsync:=1;
 colpf3:=$88;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 wsync:=1;
 colpf2:=$35;
 colpf1:=$e;
 wsync:=1;
 
 asm { plr };
end; // MadPascal add RTI
 
 
begin
 GetIntVec(iDLI, old_dli);
 
 ptext:= pointer(stext);
 
 dpoke(560,word(@dl));
 dpoke(88,mtext);
 
 clrscr;
 gotoxy(4,1);
 
 SetIntVec(iDLI,@dli);
 nmien:=$c0;
 
 writeln('  <---Hscroll with MadPascal--->');
 gotoxy(15,11);
 write('press key');
 
 repeat
 
 pause;
// pause;
 
 if count=0 then begin
 
  count:=8;
 
  poke(scrol+23, ptext^);
 
  move(pointer(scrol+1), pointer(scrol), 23);
 
  inc(ptext);
  if ptext^=$ff then ptext:=pointer(stext);
 end;
 
 dec(count);
 hscrol:=count;
 
 until keypressed;
 
 SetIntVec(iDLI, old_dli);
 
end.

Attached Files


Edited by tebe, Sun Jun 19, 2016 6:50 AM.


#23 tebe OFFLINE  

tebe

    Dragonstomper

  • 628 posts
  • Location:Poznań - Poland

Posted Sun Jun 19, 2016 6:47 AM

 
// Puzzle
 
uses crt, joystick, sysutils;
 
var field: array [0..255] of byte;
x, y, blank: byte;
 
level: byte = 10;
size: byte = 5;
 
 
procedure MoveCell(a: byte);
var idx: byte;
begin
idx := y*size + x;
 
case a of
joy_left: if x<size-1 then begin field[idx]:=field[idx+1]; field[idx+1]:=blank; inc(x) end;
joy_right: if x>0 then begin field[idx]:=field[idx-1]; field[idx-1]:=blank; dec(x) end;
  joy_up: if y<size-1 then begin field[idx]:=field[idx+size]; field[idx+size]:=blank; inc(y) end;
joy_down: if y>0 then begin field[idx]:=field[idx-size]; field[idx-size]:=blank; dec(y) end;
end;
end;
 
 
procedure Initialize(cnt: word);
var i: word;
begin
 
 blank := (size div 2)*(size+1);
 
 for i:=0 to size*size-1 do field[i] := i;
  
 x:=blank mod size;
 y:=blank div size;
 
 for i:=0 to cnt do 
  case byte(random(4)) of
   0: MoveCell(joy_left);
   1: MoveCell(joy_right);
   2: MoveCell(joy_up);
   3: MoveCell(joy_down);
  end;
 
end;
 
 
procedure Display;
var i,j, idx: byte;
begin
 
 for j:=0 to size-1 do
  for i:=0 to size-1 do begin
 
  GotoXY(i shl 2+6, j shl 1+5);
 
   idx:=j*size+i;
 
   if field[idx] = blank then
    write('  ')
   else  
    write(field[idx]);
 
  end;
 
 
end;
 
 
function Check: Boolean;
var i: byte;
begin
 
 Result:=true;
 
 for i:=0 to size*size-1 do 
  if field[i] <> i then begin Result:=false; Break end;
 
end;
 
 
begin
 
 if ParamCount > 0 then begin
  size:=StrToInt(ParamStr(1));
  level:=StrToInt(ParamStr(2));
 
  if (size<2) or (size> 8) or (level<2) then begin
   writeln(#$9b'Usage:'#$9b,'PUZZLE size level');
   writeln('size = [2..8], level = [2..65535]');
   halt;  
  end;
  
 end;
 
 
 ClrScr; CursorOff; Randomize;
 
 Initialize(level);
 
 Display;
 
 repeat
Pause;
 
MoveCell(joy_1);
 
if joy_1 <> joy_none then Display;
 
if Check then begin
writeln(#$9b#$9b#$9b'Congratulations !');
Break;
end;
 
 until keypressed;
 
 CursorOn;
 writeln;
 
end.

Attached Files


Edited by tebe, Sun Jun 19, 2016 6:49 AM.


#24 tebe OFFLINE  

tebe

    Dragonstomper

  • 628 posts
  • Location:Poznań - Poland

Posted Sat Jul 2, 2016 12:13 PM

R.O.T.O. (Mad Pascal 1.3.8)

 

Attached Files

  • Attached File  roto.zip   14.14KB   160 downloads


#25 Gury OFFLINE  

Gury

    Stargunner

  • Topic Starter
  • 1,197 posts

Posted Mon Jul 4, 2016 2:20 AM

Waw, R.O.T.O. in Mad Pascal, very smooth and colorful, thanks for code demonstration, Tebe.

I missed puzzle game from previous post, tracked it now.






0 user(s) are browsing this forum

0 members, 0 guests, 0 anonymous users