tebe Posted May 30, 2017 Share Posted May 30, 2017 not implemented yet const screen = $b000; var dl: array ....... Quote Link to comment Share on other sites More sharing options...
peteym5 Posted May 30, 2017 Share Posted 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. 1 Quote Link to comment Share on other sites More sharing options...
bocianu Posted August 6, 2017 Share Posted August 6, 2017 (edited) 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 3 Quote Link to comment Share on other sites More sharing options...
tebe Posted September 9, 2017 Share Posted September 9, 2017 Popcorn tune popcorn.zip 2 Quote Link to comment Share on other sites More sharing options...
tebe Posted September 17, 2017 Share Posted September 17, 2017 (edited) Load Windows Bitmap (VBXE) 4BitPerPixel, 8BitPerPixel SolidFill example loadbmp.zip solidfill.zip Edited September 17, 2017 by tebe 2 Quote Link to comment Share on other sites More sharing options...
tebe Posted September 24, 2017 Share Posted September 24, 2017 (edited) 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 3 Quote Link to comment Share on other sites More sharing options...
tebe Posted December 13, 2017 Share Posted 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 6 Quote Link to comment Share on other sites More sharing options...
tebe Posted December 13, 2017 Share Posted December 13, 2017 MOD Player Syntax: X MODPLAY.EXE FILENAME.MOD 2 Quote Link to comment Share on other sites More sharing options...
+MrFish Posted December 13, 2017 Share Posted December 13, 2017 Cool! Quote Link to comment Share on other sites More sharing options...
+CharlieChaplin Posted December 13, 2017 Share Posted December 13, 2017 This MOD-player works with SDX only ? Quote Link to comment Share on other sites More sharing options...
tebe Posted December 14, 2017 Share Posted December 14, 2017 SDX, BW-Dos etc. Quote Link to comment Share on other sites More sharing options...
tebe Posted December 14, 2017 Share Posted December 14, 2017 (edited) 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 3 Quote Link to comment Share on other sites More sharing options...
gozar Posted February 5, 2018 Share Posted 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? Quote Link to comment Share on other sites More sharing options...
Gury Posted February 7, 2018 Author Share Posted 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 1 Quote Link to comment Share on other sites More sharing options...
gozar Posted February 24, 2018 Share Posted February 24, 2018 Anyone have an example of using RMT for sound effects? Or multiple songs? Quote Link to comment Share on other sites More sharing options...
bocianu Posted February 25, 2018 Share Posted February 25, 2018 (edited) 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 Quote Link to comment Share on other sites More sharing options...
tebe Posted February 25, 2018 Share Posted February 25, 2018 lib\rmt.pas procedure Init(a: byte); assembler; procedure Play; assembler; procedure Sfx(effect, channel, note: byte); assembler; procedure Stop; assembler; Quote Link to comment Share on other sites More sharing options...
tebe Posted May 1, 2018 Share Posted 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. 3 Quote Link to comment Share on other sites More sharing options...
tebe Posted May 1, 2018 Share Posted 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. 2 Quote Link to comment Share on other sites More sharing options...
tebe Posted May 1, 2018 Share Posted May 1, 2018 (edited) 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 2 Quote Link to comment Share on other sites More sharing options...
Gury Posted May 1, 2018 Author Share Posted May 1, 2018 Very nice, thank you for the code. Quote Link to comment Share on other sites More sharing options...
tebe Posted May 13, 2018 Share Posted May 13, 2018 (edited) 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 2 Quote Link to comment Share on other sites More sharing options...
+Sheddy Posted May 13, 2018 Share Posted 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? Quote Link to comment Share on other sites More sharing options...
flashjazzcat Posted May 13, 2018 Share Posted May 13, 2018 (edited) 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 1 Quote Link to comment Share on other sites More sharing options...
+Sheddy Posted May 13, 2018 Share Posted May 13, 2018 Thanks for taking the time. No wonder I was struggling manually! Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.