Mad Pascal examples

tebe · May 30, 2017

not implemented yet

const
 screen = $b000;
 
var
 dl: array .......

peteym5 · May 30, 2017

Thanks, that is what I ended up doing. I like using constants because If I need to change something, all I need to do is change the constant value and everything is changed throughout the whole game.

bocianu · August 6, 2017

Hello Guys!

I've ported datamatrix generator (https://github.com/pfusik/datamatrix6502) into MadPascal unit.

There are also two examples how to use it.
Maybe you will find it useful somehow

DataMatrix.zip

Edited August 6, 2017 by bocianu

tebe · September 9, 2017

Popcorn tune

popcorn.zip

tebe · September 17, 2017

Load Windows Bitmap (VBXE) 4BitPerPixel, 8BitPerPixel

SolidFill example

loadbmp.zip

solidfill.zip

Edited September 17, 2017 by tebe

tebe · September 24, 2017

VIMAGE unit (VBXE), LoadVBMP, LoadVPCX, LoadVGIF (GIF87a only)

{****************************************************************************
** VImage unit,								   **
**   by Steven Don, Tomasz Biela					   **
*****************************************************************************
** A unit to load a variety of image formats to a buffer.		   **
**                                                                         **
** Supported image formats are: Windows BMP				   **
**                              Compuserve GIF (87a)			   **
**                              Z-Soft PCX				   **
**                                                                         **
** Images must be in 256 colours and may be up to 336x240 in size.         **
*****************************************************************************
** Three functions are available to the calling program:		   **
**                                                                         **
**   LoadVBMP (FileName, Location);					   **
**   LoadVGIF (FileName, Location);					   **
**   LoadVPCX (FileName, Location);					   **
**                                                                         **
** Name is the filename, including extension (e.g. TEST.GIF)               **
** Location is a pointer to an Array [0..64000] of Byte; where the image   **
** data will be stored.                                                    **
** All functions are boolean. If they return false, check IMGERROR to find **
** out what happened.                                                      **
**                                                                         **
****************************************************************************}

vimage.zip

Edited September 24, 2017 by tebe

tebe · December 13, 2017

MOD Player (6502, PAL)

// 6502 MOD Player 1.0
// pattern limit = 37
// sample length limit = 16384 bytes
 
// volume $de00 - $feff
 
// playloop = $0000
// mainloop = $0400..$5ff
 
 
program ModPlay;
 
uses crt, atari, objects;
 
{$r modplay.rc}
 
type
 
TName = array [0..21] of char;
 
TSample = packed record
name : TName;
len : word;
fine_tune,
volume : byte;
loop_start,
loop_len : word;
end;
 
TPSample = ^TSample;
 
 
const
ZPAGE = $db00;
EFFECT = $dc00; // adres skoku przy dekodowaniu efektu sampla
TADCL = $dd00; // mlodsze bajty przyrostu offsetu dla sampla (nuta)
TADCH = TADCL + $30; // starsze bajty przyrostu offsetu dla sampla (nuta)
 
VOLUME = $de00; // 33 tablice glosnosci (pierwsza tablica zawiera same zera)
 
pattern_start = $4000; // $4000..$9FFF $4000 + 192*128
sample_start = $4000;
sample_len = $4000;
 
PATTERN_LIMIT = 37;
SAMPLE_LIMIT = 31;
 
 
KOD : array [0..47] of word = (
$6b0,$650,$5f4,$5a0,
$54c,$500,$4b8,$474,
$434,$3f8,$3c0,$380,
$358,$328,$2fa,$2d0,
$2a6,$280,$25c,$23a,
$21a,$1fc,$1e0,$1c5,
$1ac,$194,$17d,$168,
$153,$140,$12e,$11d,
$10d,$fe,$f0,$e2,
$d6,$ca,$be,$b4,
$aa,$a0,$97,$8f,
$87,$7f,$78,$71
);
 
var
BUF: array [0..255] of byte absolute $0500;
 
TIVOL: array [0..31] of byte absolute $0150; // starszy adres glosnosci tablicy VOLUME = glosnosc SAMPLA
 
ORDER: array [0..127] of byte absolute $0600; // tablica SONG ORDER
TSTRL: array [0..31] of byte absolute $0680; // mlodszy bajt adresu poczatkowego sampla
TSTRH: array [0..31] of byte absolute $06A0; // starszy bajt adresu poczatkowego sampla
TREPL: array [0..31] of byte absolute $06C0; // mlodszy bajt adresu powtorzenia sampla
TREPH: array [0..31] of byte absolute $06E0; // starszy bajt adresu powtorzenia sampla
 
ModName: array [0..19+1] of char;
 
sampl_0, sampl_1, sampl_2, sampl_3, sampl_4,
sampl_5, sampl_6, sampl_7, sampl_8, sampl_9,
sampl_10, sampl_11, sampl_12, sampl_13,
sampl_14, sampl_15, sampl_16, sampl_17,
sampl_18, sampl_19, sampl_20, sampl_21,
sampl_22, sampl_23, sampl_24, sampl_25,
sampl_26, sampl_27, sampl_28, sampl_29, sampl_30: TSample;
 
Sample: array [0..30] of pointer = (
@sampl_0, @sampl_1, @sampl_2, @sampl_3, @sampl_4,
@sampl_5, @sampl_6, @sampl_7, @sampl_8, @sampl_9,
@sampl_10, @sampl_11, @sampl_12, @sampl_13,
@sampl_14, @sampl_15, @sampl_16, @sampl_17,
@sampl_18, @sampl_19, @sampl_20, @sampl_21,
@sampl_22, @sampl_23, @sampl_24, @sampl_25,
@sampl_26, @sampl_27, @sampl_28, @sampl_29, @sampl_30);
 
xms: TMemoryStream;
 
gchar: char;
 
SONG_LENGTH,
SONG_RESTART,
NUMBER_OF_PATTERNS,
NUMBER_OF_SAMPLES : byte;
 
 
 
procedure Play(pokey: Boolean); assembler;
asm
{
vbl = $d8
 
.zpvar = $d8
 
.zpvar nr0, nr1, nr2, nr3, patno, patend, cnts, pause, track_pos .byte
.zpvar pat0, pat1, pat2 .word
 
stx _rx
 
jsr wait
 
sei
 
inc nmien
mva #$fe portb
 
ldx #0
mva:rne 0,x ZPAGE,x+
 
ldx #0
mv0 lda .adr(playloop),x
sta playloop,x
inx
cpx #.sizeof(playloop)
bne mv0
 
ldx #0
mv1 lda .adr(mainloop),x
sta mainloop,x
lda .adr(mainloop)+$100,x
sta mainloop+$100,x
inx
bne mv1
 
mva #0 audctl
mva #3 skctl
 
lda SONG_LENGTH
sta mainloop.patmax+1
 
; lda SONG_RESTART
; sta mainloop.patres+1
 
lda >volume ; silence
sta playloop.ivol10+2
sta playloop.ivol11+2
sta playloop.ivol12+2
sta playloop.ivol13+2
 
lda POKEY
bne skip
 
lda >$d600 ; covox
sta playloop.ch0+2
sta playloop.ch1+2
sta playloop.ch2+2
sta playloop.ch3+2
 
ldy #0
sty playloop.ch0+1
iny
sty playloop.ch1+1
iny
sty playloop.ch2+1
iny
sty playloop.ch3+1
 
jmp start
 
skip lda >VOLUME
sta av0+1
sta av1+1
 
ldx #32 ; POKEY volume table
ldy #0
mvol lda VOLUME,y
av0 equ *-2
:4 lsr @
ora #$10
sta VOLUME,y
av1 equ *-2
iny
bne mvol
 
inc av0+1
inc av1+1
dex
bpl mvol
 
start lda #0
sta dmactl
sta patno
sta track_pos
 
sta pat0
sta pat1
sta pat2
 
lda #6
sta pause
sta cnts
 
ldy adr.ORDER
sty pat0+1
iny
sty pat1+1
iny
sty pat2+1
 
jmp mainloop
 
 
.local playloop,0
 
; ---
; --- AUDC 1
; ---
 
bank0 lda #$fe ; ch #0
sta portb
 
p_0c ldx $ffff
ivol10 lda volume,x
ch0 sta audc1
 
ist_0 lda #0
iad0_m adc #0
sta ist_0+1
lda p_0c+1
iad0_s adc #0
bcc ext_0
 
inc p_0c+2
bpl ext_0
 
ire0_s lda #0
sta p_0c+2
ire0_m lda #0
 
ext_0 sta p_0c+1
 
; ---
; --- AUDC 2
; ---
 
bank1 lda #$fe ; ch #1
sta portb
 
p_1c ldx $ffff
ivol11 lda volume,x
ch1 sta audc2
 
ist_1 lda #0
iad1_m adc #0
sta ist_1+1
lda p_1c+1
iad1_s adc #0
bcc ext_1
 
inc p_1c+2
bpl ext_1
 
ire1_s lda #0
sta p_1c+2
ire1_m lda #0
 
ext_1 sta p_1c+1
 
; ---
; --- AUDC 3
; ---
 
bank2 lda #$fe ; ch #2
sta portb
 
p_2c ldx $ffff
ivol12 lda volume,x
ch2 sta audc3
 
ist_2 lda #0
iad2_m adc #0
sta ist_2+1
lda p_2c+1
iad2_s adc #0
bcc ext_2
 
inc p_2c+2
bpl ext_2
 
ire2_s lda #0
sta p_2c+2
ire2_m lda #0
 
ext_2 sta p_2c+1
 
; ---
; --- AUDC 4
; ---
 
bank3 lda #$fe ; ch #3
sta portb
 
p_3c ldx $ffff
ivol13 lda volume,x
ch3 sta audc4
 
ist_3 lda #0
iad3_m adc #0
sta ist_3+1
lda p_3c+1
iad3_s adc #0
bcc ext_3
 
inc p_3c+2
bpl ext_3
 
ire3_s lda #0
sta p_3c+2
ire3_m lda #0
 
ext_3 sta p_3c+1
 
dey
jne playloop
 
ldy #vbl
 
dec cnts
jne playloop
 
jmp mainloop
 
.endl
 
 
.local mainloop,$0400
 
lda #0
sta patend
 
lda #$fe
sta portb
 
ldy track_pos
 
*---------------------------
* track  0
 
i_0 ;ldy #1
lda (pat1),y
sta i_0c+1
and #$1f
beq i_0c
tax
sta nr0
lda adr.tivol-1,x
sta playloop.ivol10+2
 
i_0c ldx EFFECT
beq i_0f
cpx #$40
bne @+
;ldy #2
lda (pat2),y
sta playloop.ivol10+2
@ cpx #$c0
bne @+
;ldy #2
lda (pat2),y
sta pause
@ cpx #$80
bne i_0f
stx patend
 
i_0f ;ldy #0
lda (pat0),y
beq i_1
tax
lda tadcl-1,x
sta playloop.iad0_m+1
lda tadch-1,x
sta playloop.iad0_s+1
 
; lda #0
; sta playloop.ist_0+1
 
ldx nr0
lda main.misc.adr.banks-1,x
sta playloop.bank0+1
 
lda adr.tstrl-1,x
sta playloop.p_0c+1
lda adr.tstrh-1,x
sta playloop.p_0c+2
 
lda adr.trepl-1,x
sta playloop.ire0_m+1
lda adr.treph-1,x
sta playloop.ire0_s+1
 
* track 1
 
i_1 iny
 
;ldy #4
lda (pat1),y
sta i_1c+1
and #$1f
beq i_1c
tax
sta nr1
lda adr.tivol-1,x
sta playloop.ivol11+2
 
i_1c ldx EFFECT
beq i_1f
cpx #$40
bne @+
;ldy #5
lda (pat2),y
sta playloop.ivol11+2
@ cpx #$c0
bne @+
;ldy #5
lda (pat2),y
sta pause
@ cpx #$80
bne i_1f
stx patend
 
i_1f ;ldy #3
lda (pat0),y
beq i_2
tax
lda tadcl-1,x
sta playloop.iad1_m+1
lda tadch-1,x
sta playloop.iad1_s+1
 
; lda #0
; sta playloop.ist_1+1
 
ldx nr1
lda main.misc.adr.banks-1,x
sta playloop.bank1+1
 
lda adr.tstrl-1,x
sta playloop.p_1c+1
lda adr.tstrh-1,x
sta playloop.p_1c+2
 
lda adr.trepl-1,x
sta playloop.ire1_m+1
lda adr.treph-1,x
sta playloop.ire1_s+1
 
* track 2
 
i_2 iny
 
;ldy #7
lda (pat1),y
sta i_2c+1
and #$1f
beq i_2c
tax
sta nr2
lda adr.tivol-1,x
sta playloop.ivol12+2
 
i_2c ldx EFFECT
beq i_2f
cpx #$40
bne @+
;ldy #8
lda (pat2),y
sta playloop.ivol12+2
@ cpx #$c0
bne @+
;ldy #8
lda (pat2),y
sta pause
@ cpx #$80
bne i_2f
stx patend
 
i_2f ;ldy #6
lda (pat0),y
beq i_3
tax
lda tadcl-1,x
sta playloop.iad2_m+1
lda tadch-1,x
sta playloop.iad2_s+1
 
; lda #0
; sta playloop.ist_2+1
 
ldx nr2
lda main.misc.adr.banks-1,x
sta playloop.bank2+1
 
lda adr.tstrl-1,x
sta playloop.p_2c+1
lda adr.tstrh-1,x
sta playloop.p_2c+2
 
lda adr.trepl-1,x
sta playloop.ire2_m+1
lda adr.treph-1,x
sta playloop.ire2_s+1
 
* track 3
 
i_3 iny
 
;ldy #10
lda (pat1),y
sta i_3c+1
and #$1f
beq i_3c
tax
sta nr3
lda adr.tivol-1,x
sta playloop.ivol13+2
 
i_3c ldx EFFECT
beq i_3f
cpx #$40
bne @+
;ldy #11
lda (pat2),y
sta playloop.ivol13+2
@ cpx #$c0
bne @+
;ldy #11
lda (pat2),y
sta pause
@ cpx #$80
bne i_3f
stx patend
 
i_3f ;ldy #9
lda (pat0),y
beq i_e
tax
lda tadcl-1,x
sta playloop.iad3_m+1
lda tadch-1,x
sta playloop.iad3_s+1
 
; lda #0
; sta playloop.ist_3+1
 
ldx nr3
lda main.misc.adr.banks-1,x
sta playloop.bank3+1
 
lda adr.tstrl-1,x
sta playloop.p_3c+1
lda adr.tstrh-1,x
sta playloop.p_3c+2
 
lda adr.trepl-1,x
sta playloop.ire3_m+1
lda adr.treph-1,x
sta playloop.ire3_s+1
 
i_e
lda patend
bne i_en
 
iny
sty track_pos
bne i_end
 
i_en inc patno
ldx patno
patmax cpx #0
bcc i_ens
 
lda #6
sta pause
patres ldx #0
stx patno
 
i_ens ldy adr.ORDER,x
sty pat0+1
iny
sty pat1+1
iny
sty pat2+1
 
lda #0
sta track_pos
 
i_end lda skstat
and #4
sne
 
jmp stop_
 
lda pause
sta cnts
ldy #vbl
jmp PLAYLOOP
 
.endl
 
 
wait lda skstat ; wait on keypress
and #4
beq wait
 
wai_ lda vcount
cmp #$70
bne wai_
rts
 
stop_ jsr wait
 
ldx #0
mva:rne ZPAGE,x 0,x+
 
lda #$ff
sta portb
 
lda irqens
sta IRQEN
 
dec nmien
cli
 
ldx #0
_rx equ *-1
 
};
end;
 
 
 
function CnvPattern: cardinal; assembler;
asm
{
lda #0
sta Result
sta Result+1
sta Result+2
sta Result+3
 
lda adr.BUF
and #$f
ora adr.BUF+1
beq _sil
 
ldy #0
_tst lda adr.KOD,y
cmp adr.BUF+1
bne pls
lda adr.BUF ;kod dzwieku
and #$f
cmp adr.KOD+1,y
bne pls
iny
iny
tya
lsr @
; ldy #0
sta Result ;czestotliwosc
 
lda adr.BUF+2 ;oblicz nr instr
lsr @
lsr @
lsr @
lsr @
sta or_+1
lda adr.BUF
and #$f0
or_ ora #0
and #$1f
; ldy #1
_con sta Result+1 ;numer instrumentu
 
; ldy #2
lda #0
sta Result+2
; dey
lda adr.BUF+2
and #$f
cmp #$c
beq _vol ; Effect Cxy (Set Volume)
cmp #$f
beq _tmp ; Effect Fxy (Set Speed)
cmp #$d
beq _break ; Effect Dxy (Pattern Break)
jmp stop
 
_sil sta Result
beq _con
 
_break lda #$80
ora Result+1
sta Result+1
bne stop
 
_vol lda #$40
ora Result+1
sta Result+1
 
lda adr.BUF+3 ;parametr komendy
 
lsr @
clc
adc >VOLUME
sta Result+2
bne stop
 
_tmp lda adr.BUF+3
cmp #$20
bcs _tq
lda #$c0
ora Result+1
sta Result+1
; ldy #2
lda adr.BUF+3 ;parametr komendy
and #$1f
sta Result+2
_tq
jmp stop
 
pls iny
iny
cpy #96
 
jne _tst
 
stop
};
end;
 
 
procedure LoadMOD(fnam: TString);
var f: file;
    name: TString;
    i, j, a, x, y, num: byte;
    offset, tmp: cardinal;
    temp, len: word;
    smp: TPSample;
    p0, p1, p2: ^byte;
    header: string[4];
 
 
    procedure NormalizeBuf;
    begin
 
for j:=0 to 255 do
buf[j] := buf[j] + $80;
 
    end;
 
 
begin
 
 name:='D:';
 name[0]:=chr(length(fnam)+2);
 
 for i:=1 to length(fnam) do // 'D:' + filename
  name[i+2]:=fnam[i];
 
 
 assign(f, name); reset(f, 1);
 
 blockread(f, ModName, 20); // Load Module Name
 
 NUMBER_OF_SAMPLES := 0;
 
 for i:=0 to 30 do begin // Load Sample Information
 
  smp:=Sample[i];
 
  blockread(f, smp.name, sizeof(TSample));
 
  smp.len := swap(smp.len) shl 1;
  smp.loop_start := swap(smp.loop_start) shl 1;
  smp.loop_len := swap(smp.loop_len) shl 1;
 
  if smp.len<>0 then inc(NUMBER_OF_SAMPLES);
 
  if smp.len > sample_len then begin
   writeln('Only ',sample_len,' bytes length sample');
   halt;
  end;
 
 end;
 
 
 blockread(f, SONG_LENGTH, 1);
 blockread(f, SONG_RESTART, 1);
 
 
 NUMBER_OF_PATTERNS := 0; // Load Order Information
 
 for i:=0 to 127 do begin
  blockread(f, a, 1);
 
  ORDER[i]:=hi(PATTERN_START) + a shl 1+a; // + a*3
 
  if a > NUMBER_OF_PATTERNS then NUMBER_OF_PATTERNS:=a;
 end;
 
 inc(NUMBER_OF_PATTERNS); // pattern #0 -> +1
 
 
 blockread(f, header[1], 4);
 header[0]:=chr(4);
 
 if header <> 'M.K.' then begin
  writeln('Unsuported MOD file');
 
  halt;
 end;
 
 
 writeln('Name: ',ModName); // Information About Module
 
 for i:=0 to 30 do begin
 
  smp:=Sample[i];
 
  if smp.len<>0 then
   writeln(hexStr(i+1, 2),' ',smp.name,' ', hexStr(smp.len,4),' ', hexStr(smp.fine_tune,2),' ', hexStr(smp.volume,2),' ', hexStr(smp.loop_start,4),' ', hexStr(smp.loop_len,4) );
 
 end;
 
 
 if NUMBER_OF_PATTERNS > PATTERN_LIMIT then begin
  writeln('Samples: ',NUMBER_OF_PATTERNS);
  writeln('Only ',PATTERN_LIMIT,' samples allowed');
  halt;
 end;
 
 
 if NUMBER_OF_SAMPLES > SAMPLE_LIMIT then begin
  writeln('Samples: ',NUMBER_OF_SAMPLES);
  writeln('Only ',SAMPLE_LIMIT,' samples allowed');
  halt;
 end;
 
 temp:=pattern_start; // $4000..$9FFF
 
 writeln;
 write('Load Pattern: ');
 x:=WhereX;
 y:=WhereY;
 
 for i:=1 to NUMBER_OF_PATTERNS do begin // Load Pattern Data
 
  p0:=pointer(temp);
  p1:=pointer(temp+$100);
  p2:=pointer(temp+$200);
 
  GotoXY(x,y);
  write(i,'/',NUMBER_OF_PATTERNS);
 
  for j:=0 to 255 do begin
   blockread(f, buf, 4);
 
   tmp:=CnvPattern;
 
   p0^:=tmp; inc(p0);
   p1^:=tmp shr 8; inc(p1);
   p2^:=tmp shr 16; inc(p2);
  end;
 
  inc(temp, $300);
 
 end;
 
 
 writeln;
 write('Load Sample: ');
 x:=WhereX;
 y:=WhereY;
 
 offset:=0;
 num:=1;
 
 for i:=0 to 30 do begin // Load Sample Data
 
  TSTRL[i] := lo(VOLUME);
  TSTRH[i] := hi(VOLUME);
  TREPL[i] := lo(VOLUME);
  TREPH[i] := hi(VOLUME);
 
  TIVOL[i] := hi(VOLUME);
 
  smp:=Sample[i];
 
  len := smp.len;
 
  if len <> 0 then begin
 
  GotoXY(x,y);
  write(num,'/',NUMBER_OF_SAMPLES);
 
  temp:=sample_len - len;
 
  xms.position := temp + offset; // sampl konczy sie na $7fff
 
  inc(temp, sample_start);
 
  TSTRL[i] := lo(temp);
  TSTRH[i] := hi(temp);
 
  if (smp.loop_start = 0 ) and (smp.loop_len < 5) then
   temp := VOLUME // skoncz i graj cisze
  else // sample na poczatku maja 4 zera (dla wyciszenia)
   inc(temp, smp.loop_start);
 
  TREPL[i] := lo(temp);
  TREPH[i] := hi(temp);
 
  TIVOL[i] := hi(VOLUME) + smp.volume shr 1;
 
  while len > 0 do begin
 
   if len >= 256 then
    temp:=256
   else
    temp:=len;
 
   BlockRead (f, buf, temp);
   NormalizeBuf;
   xms.WriteBuffer(buf, temp);
 
   dec(len, temp);
 
  end;
 
  inc(num);
 
  end; // if len <> 0
 
  inc(offset, $4000);
 
 end;
 
 writeln;
 
 close(f);
 
end;
 
 
begin
 
 lmargin:=0;
 
 clrscr;
 
 writeln('MOD Player 1.0',eol);
 
 sdmctl := ord(dmactl.enable) + ord(dmactl.normal);
 
 pause;
 
 
 if ParamCount > 0 then begin
 
 
 xms.Create;
 
 if xms.Size < SAMPLE_LIMIT*$4000 then begin
  writeln('Need minimum ',SAMPLE_LIMIT,' banks expanded memory');
  halt;
 end;
 
 
 LoadMOD(ParamStr(1));
 
// LoadMOD('D:POPCORN.MOD');
 
 writeln;
 writeln('Select: P-okey, C-ovox');
 
 gchar:=UpCase(readkey);
 
 Play(gchar = 'P');
 
 end;
 
end.

mod_sdx.zip

tebe · December 13, 2017

MOD Player
 
Syntax:
 
X MODPLAY.EXE FILENAME.MOD

+MrFish · December 13, 2017

Cool! :thumbsup:

+CharlieChaplin · December 13, 2017

This MOD-player works with SDX only ?

tebe · December 14, 2017

SDX, BW-Dos etc.

tebe · December 14, 2017

lower requirements for additional memory

MOD Player 1.1

MOD Player 2.0 (CPU > 3 MHz)

mod_sdx_2.zip

Edited December 14, 2017 by tebe

gozar · February 5, 2018

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;

Does the pmg library have a limit on how tall players can be?

Gury · February 7, 2018

Hi gozar,

the limit of player vertical data is determined by constant _P_MAX in pmg library. You can amend it to any value you wish. That means you must fill all blank data values with zeroes.

Greetings

gozar · February 24, 2018

Anyone have an example of using RMT for sound effects? Or multiple songs?

bocianu · February 25, 2018

You can find both in Pac-Mad sources:

https://gitlab.com/bocianu/PacMad

Look for "msx" in file pacmad.pas

regards!

Edited February 25, 2018 by bocianu

tebe · February 25, 2018

lib\rmt.pas

procedure Init(a: byte); assembler;
procedure Play; assembler;
procedure Sfx(effect, channel, note: byte); assembler;
procedure Stop; assembler;

tebe · May 1, 2018

TETRIS

{--------------------------------------}
{slightly corrected by Valery Votintsev}
{--------------------------------------}
{ key A LEFT        }
{ key D RIGHT        }
{ key W UP        }
{ key S DOWN        }
{--------------------------------------}
 
program tetris;
uses
  crt;
var
  ss,nn,a,b,c,d,lin,rlin,x,y,pus: byte;
  st:array[0..12, 0..22] of byte;
 
procedure k(x,y:byte);
begin
 gotoxy(x*2+12,24-y);
 if ss=0 then write('  ');
 if ss=1 then write('[]');
 if ss=2 then write(chr(177),chr(177));
 if (ss=3) and (st[x,y]>0) then pus:=1;
 if ss=4 then st[x,y]:=1;
 gotoxy(1,1);write(' ');
end;
 
procedure fig(x,y,n,s:byte);
begin
 if s=3 then pus:=0;
 ss:=s; k(x,y);
 if n=1 then begin k(x+1,y);k(x,y-1);k(x+1,y-1) end;
 if n=2 then begin k(x-1,y);k(x+1,y);k(x+2,y) end;
 if n=3 then begin k(x,y+1);k(x,y-1);k(x,y-2) end;
 if n=4 then begin k(x+1,y);k(x-1,y);k(x-1,y+1) end;
 if n=5 then begin k(x,y+1);k(x+1,y+1);k(x,y-1) end;
 if n=6 then begin k(x-1,y);k(x+1,y);k(x+1,y-1) end;
 if n=7 then begin k(x,y+1);k(x,y-1);k(x-1,y-1) end;
 if n=8 then begin k(x-1,y);k(x+1,y);k(x+1,y+1) end;
 if n=9 then begin k(x,y+1);k(x,y-1);k(x+1,y-1) end;
 if n=10 then begin k(x+1,y);k(x-1,y);k(x-1,y-1) end;
 if n=11 then begin k(x,y+1);k(x,y-1);k(x-1,y+1) end;
 if n=12 then begin k(x-1,y);k(x,y-1);k(x+1,y-1) end;
 if n=13 then begin k(x,y+1);k(x-1,y);k(x-1,y-1) end;
 if n=14 then begin k(x+1,y);k(x-1,y-1);k(x,y-1) end;
 if n=15 then begin k(x-1,y);k(x,y-1);k(x-1,y+1) end;
 if n=16 then begin k(x+1,y);k(x-1,y);k(x,y+1) end;
 if n=17 then begin k(x+1,y);k(x,y+1);k(x,y-1) end;
 if n=18 then begin k(x,y-1);k(x-1,y);k(x+1,y) end;
 if n=19 then begin k(x-1,y);k(x,y+1);k(x,y-1) end
end;
 
procedure pov;
begin
 nn:=nn-1;
 if nn=15 then nn:=19;
 if nn=13 then nn:=15;
 if nn=11 then nn:=13;
 if nn=7 then nn:=11;
 if nn=3 then nn:=7;
 if nn=1 then nn:=3;
 if nn=0 then nn:=1;
end;
 
procedure clrst;
begin
 for x:=1 to 12 do
  for y:=1 to 22 do
   if (x=1) or (x=12) or (y=1) then st[x,y]:=2 else st[x,y]:=0;
end;
 
procedure risvesst;
begin
 for x:=1 to 12 do
  for y:=1 to 22 do begin
    ss:=st[x,y];
    k(x,y);
  end;
end;
 
procedure dvig;
var
 i:byte;
 key:char;
begin
 for i:=1 to 10 do
  begin
  delay(d);
  key:=' ';
  if keypressed then key:=readkey;
  if key='a' then
   begin
   fig(x-1,y,nn,3);
   if pus=0 then begin fig(x,y,nn,0); x:=x-1; fig(x,y,nn,1); end;
   end;
  if key='d' then
   begin
   fig(x+1,y,nn,3);
   if pus=0 then begin fig(x,y,nn,0); x:=x+1; fig(x,y,nn,1); end;
   end;
  if key='w' then
   begin
   pov; fig(x,y,nn,3); pov;pov;pov;
   if pus=0 then begin fig(x,y,nn,0); pov; fig(x,y,nn,1); end;
   end;
  if key='s' then d:=5;
  end;
end;
 
 
 
begin
 randomize;
 clrscr;
 clrst;
 risvesst;
 lin:=0;
 
 repeat
 
  nn:=1+random(18);
  x:=6;y:=20; fig(x,y,nn,3); d:=70-(lin*5);
 
 
  if pus=0 then
   begin
    repeat
     fig(x,y,nn,1);
     dvig;
     fig(x,y-1,nn,3);
     if pus=0 then begin fig(x,y,nn,0); y:=y-1; end;
    until pus=1;
 
 
    fig(x,y,nn,4);
    for y:=22 downto 2 do
     begin
      a:=0; for x:=2 to 11 do a:=a+st[x,y];
      if a=10 then
       begin
        for b:=y to 21 do for c:=2 to 11 do st[c,b]:=st[c,b+1];
        lin:=lin+1;
        gotoxy(2,2); writeln('Line: ',lin)
       end;
     end;
     risvesst;
     pus:=0;
   end;
 
 until pus=1;
 
end.

tebe · May 1, 2018

SPLINE

program SplineDemo;
{****************************************************************************
** Demonstration of drawing a Catmull-Rom spline, a curved line that       **
** passes through a number of control points.                              **
**  by Steven H Don                                                        **
**                                                                         **
** For questions, feel free to e-mail me.                                  **
**                                                                         **
**    shd@earthling.net                                                    **
**    http://shd.cjb.net                                                   **
**                                                                         **
****************************************************************************}
 
uses Crt, Graph;
 
const
  NumPts = 15;
  Resolution = 10;
 
type
 
PointType = record
             x,y: single;
    end;
 
 
var
  {Catmull-rom coefficients}
  A, B, C, D : PointType;
  {Control points}
  Px, Py : Array [0..NumPts + 1] of single;
 
  GraphDriver,GraphMode : smallint;
 
 
procedure SplinePoint (t : single; var Point : PointType);
var
  t2, t3 : single;
 
begin
 
  {Square and cube of t}
  t2 := t * t;
  t3 := t2 * t;
  {Calculate coordinates}
  Point.x := ((A.x * t3) + (B.x * t2) + (C.x * t) + D.x) / 2;
  Point.y := ((A.y * t3) + (B.y * t2) + (C.y * t) + D.y) / 2;
end;
 
{Computes coefficients for point n.
This is a matrix transform:
  -1  3 -3  1
   2 -5  4 -1
  -1  0  1  0
   0  2  0  0
}
procedure ComputeCoeffs (n : byte);
begin
  {x-coefficients}
  A.x :=    -Px [n - 1] + 3 * Px [n] - 3 * Px [n + 1] + Px [n + 2];
  B.x := 2 * Px [n - 1] - 5 * Px [n] + 4 * Px [n + 1] - Px [n + 2];
  C.x :=    -Px [n - 1]                  + Px [n + 1];
  D.x :=                  2 * Px [n];
 
  {y-coefficients}
  A.y :=    -Py [n - 1] + 3 * Py [n] - 3 * Py [n + 1] + Py [n + 2];
  B.y := 2 * Py [n - 1] - 5 * Py [n] + 4 * Py [n + 1] - Py [n + 2];
  C.y :=    -Py [n - 1]                  + Py [n + 1];
  D.y :=                  2 * Py [n];
end;
 
procedure DrawSpline (Points : byte; Colour : Byte);
var
  Point, Segment: Byte;
  Current, Next : PointType;
  a,b: single;
 
begin
  Px [0]          := Px [1];
  Py [0]          := Py [1];
 
  Px [Points + 1] := Px [Points];
  Py [Points + 1] := Py [Points];
 
  SetColor(Colour);
 
  {Loop along all the points, drawing a line to the next point}
  for Point := 1 To Points - 1 do begin
    {Calculate coefficients for this point}
    ComputeCoeffs (Point);
    {Calculate the start point for the first segment}
    SplinePoint (0, Current);
    {Split into smaller segments}
    for Segment := 1 To Resolution Do Begin
      {Calculate end point}
      SplinePoint (Segment / Resolution, Next);
      {Draw segment}
      Line (round (Current.x), Round (Current.y), Round (Next.x), Round (Next.y) );
      {Next part}
      Current := Next;
    end;
  end;
end;
 
var
  Point : Byte;
 
begin
  Randomize;
 
  GraphDriver := VGA;
  GraphMode := VGAHi;
  InitGraph(GraphDriver,GraphMode,'');
 
  repeat
 
    {Get random points}
    for Point := 1 to NumPts do begin
      Px [Point] := Random (320);
      Py [Point] := Random (200);
    end;
 
    {Draw the spline along those points}
    DrawSpline (NumPts, 15);
 
    {Draw the points themselves}
 //   for Point := 1 to NumPts do
 //     PutPixel (Round (Px [Point]), Round (Py [Point]), 1);
 
  until ReadKey = Chr (27);
end.

tebe · May 1, 2018

MANDEL

program mandel;
 
{ This program generates the Mandlebrot set fractal curves. It is taken from
Roger T. Stevens book: FRACTAL Programming in Turbo Pascal.
This is the best book to buy if you are interested in or studying fractal
curves and chaos.
 
The below program is coded to be displayed on an EGA monitor at
640 x 200 resolution. Simple modifications can be made to display the set
on a higher resolution. Using anything below an EGA display will NOT
produce the spectacular effects as do the EGA and higher modes.
 
EGADrive is a unit I wrote to link in the EGAVGA.BGI screen routines
at compile time. Notice how you don't need to specify the BGI path in
the call to InitGraph.
 
To make the program run faster on slower machines, but sacrificing detail,
change the max_iterations constant to something lower. Therefore, the
lesser the iterations, the less detailed the curves, and vice versa.
}
 
uses CRT, Graph;
 
const
max_colors = 16;
max_iterations = 16;
max_size = 4;
 
var
Q : array[0..255] of single;
XMax,YMax,XMin,YMin,
P,deltaP,deltaQ,X,Y,Xsquare,Ysquare : single;
GraphDriver,GraphMode : smallint;
color, maxcol, col, maxrow, row: byte;
ch : char;
 
begin
XMax := 1.2;
XMin := -2.0;
YMax := 1.2;
YMin :=-1.2;
GraphDriver := VGA;
GraphMode := VGAMed;
InitGraph(GraphDriver,GraphMode,'');
 
maxcol:=GetMaxX;
maxrow:=GetMaxY;
 
if maxcol > 160 then maxcol:=160;
if maxrow > 192 then maxrow:=192;
 
deltaP := (XMax - XMin) / maxcol;
deltaQ := (YMax - Ymin) / maxrow;
Q[0] := YMax;
for row := 1 to maxrow do
Q[row] := Q[row-1] - deltaQ;
P := XMin;
for col := 0 to maxcol do
begin
 
if Keypressed then exit;
 
for row := 0 to maxrow shr 1 do
begin
X := 0.0;
Y := 0.0;
Xsquare := 0.0;
Ysquare := 0.0;
color := 1;
 
repeat { this is the "meat" }
Xsquare := X*X;
 
Ysquare := Y*Y;
Y := 2*X*Y + Q[row];
X := Xsquare - Ysquare + P;
inc(color);
 
until (color>=max_iterations) OR (Xsquare + Ysquare >= max_size);
 
color:=color MOD max_colors;
 
PutPixel(col, row, color);
PutPixel(col, maxrow-row, color);
 
end;
 
P := P + deltaP;
end;
 
ch := ReadKey;
end.

in attachment:

tetris.pas

spline.pas

mandel.pas

jdata.pas (julian date converter)

all examples compatybility with FPC (Free Pascal Compiler), compile without changes for PC and XE/XL

mp_155_example.zip

Edited May 3, 2018 by tebe

Gury · May 1, 2018

Very nice, thank you for the code.

tebe · May 13, 2018

Run Length Encode

 
uses crt;
 
var
 buf: array [0..255] of byte;
 sav: array [0..255] of byte;
 tst: array [0..255] of byte;
 
 x, i: word;
 
 
procedure RLEDecompress(src,dst: pointer); assembler; register;
asm
{ txa:pha
 
 dew edx
 
 mwa ecx outputPointer
 
 lda edx+1
 sta inputPointer+1
 
 ldx edx
 
loop    jsr getByte
 beq stop
 lsr @
 
 tay
 
lp0 jsr getByte
lp1 sta $ffff
outputPointer equ *-2
 
 inw outputPointer
 
 dey
_bpl    bmi loop
 
 bcs lp0
 bcc lp1
 
getByte inx
 sne
 inc inputPointer+1
 
 lda $ff00,x ; lo(inputPointer) = 0 !!!
inputPointer equ *-2
 
 rts
 
stop pla:tax
};
end;
  
function ByteRunCompress(len: word): word;
var i, j, k, x: word;
begin
 
k := 0;
i := 0;
 
//dopoki wszystkie bajty nie sa skompresowane
while (i < len) do begin
 
//sekwencja powtarzajacych sie conajmniej 3 bajtow
if ((i < len-2) and (buf[i] = buf[i+1]) and (buf[i] = buf[i+2])) then begin
 
//zmierz dlugosc sekwencji
j := 0;
 
while ((i+j < len-2) and (buf[i+j] = buf[i+j+1]) and (buf[i+j] = buf[i+j+2]) and (j < 126)) do inc(j);
 
//wypisz spakowana sekwencje
sav[k] := byte(j+1) shl 1;
inc(k);
 
sav[k] := buf[i+j];
inc(k);
 
//przesun wskaznik o dlugosc sekwencji
inc(i, j+2);
 
//sekwencja roznych bajtow
end else begin
 
//zmierz dlugosc sekwencji
j:=0;
 
while ((i+j < len-2) and ((buf[i+j] <> buf[j+i+1]) or (buf[i+j] <> buf[j+i+2])) and (j < 128)) do inc(j);
 
//dodaj jeszcze koncowke
if ((i+j = len-2) and (j < 128)) then inc(j);
 
if ((i+j = len-1) and (j < 128)) then inc(j);
 
//wypisz spakowana sekwencje
sav[k] := byte(j-1) shl 1 or 1;
inc(k);
 
for x:=0 to j-1 do begin
 sav[k] := buf[i+x];
 inc(k);
end;
 
//przesun wskaznik o dlugosc sekwencji
inc(i, j);
end;
 
end;
 
sav[k]:=0;
 
Result:=k;
 
end;
 
 
begin
 
 buf[0]:=1;
 buf[1]:=2;
 buf[2]:=3;
 buf[3]:=3;
 buf[4]:=3;
 buf[5]:=1;
 buf[6]:=1;
 buf[7]:=12;
 buf[8]:=12;
 buf[9]:=12;
 buf[10]:=12;
 buf[11]:=3;
 buf[12]:=2;
 buf[13]:=222;
 
 x:=ByteRunCompress(14);
 
 writeln('Compress:');
 for i:=0 to x-1 do write(sav[i],',');
 
 writeln;
 writeln;
 
 RLEDecompress(sav,tst);
 
 writeln('Decompress:');
 for i:=0 to 13 do write(tst[i],',');
 
 repeat until keypressed;
 
end.

Edited May 13, 2018 by tebe

Sheddy · May 13, 2018

I can't figure out how to decode the compress line manually from the screenshot. Assuming it is correct, what kind of RLE is it please?

flashjazzcat · May 13, 2018

Bit 0 of the control byte implies a following literal sequence when set and a repeated byte when cleared. Bits 1-7 contain (length-1)*2. So the first byte of the compressed data (3) implies a literal run of the next two bytes (1 and 2). Next we get four, which we shift right to get 2 with a clear carry bit. This means three repeated instances of the next byte (3), and so on.

Edited May 13, 2018 by flashjazzcat

Sheddy · May 13, 2018

Thanks for taking the time. No wonder I was struggling manually!

Mad Pascal examples

Recommended Posts

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Link to comment

Share on other sites

Join the conversation

Recently Browsing 0 members