Mad Pascal examples

[Gury]

Put some examples here.

 

Character set redefinition example:

{
  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*, ;
  move(_CHECK, pointer(topMem+30*, ;

  // 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.

 

rnd_chars.xex

[Gury]

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

 

{
  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.

cp.xex

pmgcol.zip

Edited October 16, 2015 by Gury

[pps]

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

[Gury]

You are welcome!

[Gury]

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.

 

{
  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.

 

starfield.xex

Edited October 22, 2015 by Gury

[pps]

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.

Fraktal.zip

[tebe]

yes, Float Point will be changed

[Gury]

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.

 

{------------------------------------------------------------------------------
  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.

 

pic.atr

pic.zip

[Roydea6]

clouds.mic.txt

 

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

 

Also a nice exit to DOS would be so COOL.

 

[tebe]

 

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.

[pps]

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...

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.

Lotus_itile_song.zip

[pps]

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

Edited June 5, 2016 by pps

[tebe]

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

http://mads.atari8.info/madpascal.html#direc

Edited June 6, 2016 by tebe

[tebe]

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 June 5, 2016 by tebe

[pps]

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.

gfx_example.zip

[tebe]

thx PPS

 

another example from https://blog.greblus.net/2016/06/06/vbl-i-dli-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.

dli_scrol.zip

[Gury]

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.

gfx_example.zip

 

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

[Gury]

 

thx PPS

 

another example from https://blog.greblus.net/2016/06/06/vbl-i-dli-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.

[greblus]

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

[Xuel]

 

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;

[pps]

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.

scroll.zip

Edited June 9, 2016 by pps

[tebe]

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.

scroll2.zip

Edited June 19, 2016 by tebe

[tebe]

 

// 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>  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.

puzzle.zip

Edited June 19, 2016 by tebe

[tebe]

R.O.T.O. (Mad Pascal 1.3.

 

roto.zip

[Gury]

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.