The PMLIB.I include file resides on the Kyan Pascal 2.x Advanced Graphics Toolkit Disk.
- procedure pmstartup;
- procedure pminitialize(resolution:integer);
- procedure clear_pm_buffer(resolution:integer);
- procedure player_width(player,width:integer);
- procedure missle_width(missle,width:integer);
- procedure pmcolor(player,color:integer);
- procedure hitclear;
- procedure horiz_player_pos(player,position:integer);
- procedure horiz_missle_pos(missle,position:integer);
- procedure putshape(player,offset,length:integer; var shape:pmarray);
- procedure roll_player_buffer(player,roll:integer);
- procedure put_missle(missle,offset,length:integer; var shape:pmarray);
- function player_to_pf(player:integer):integer;
- function player_to_pl(player:integer):integer;
- function missle_to_pf(missle:integer):integer;
- function missle_to_pl(missle:integer):integer;
- procedure wait;
- procedure priority(x:integer);
Source Code
procedure pmstartup;
begin
#a
lda $224
sta vhold
lda $225
sta vhold+1
lda sdmctl
sta sdhold
#
end;
#a
vhold dw 0
sdhold db 0
#
procedure pminitialize(resolution:integer);
begin
#a
stx _t
lda #$0
sta vbflag
lda #$3
sta vbkx
lda #$20
sta pmbase
ldy #$05
lda (_sp),y
bne *+5
jmp pmoff
cmp #$02
beq pmc
;
lda sdmctl
ora #$1c
sta sdmctl
lda gractl
ora #$03
sta gractl
;
lda #>$2300
sta missle
lda #<$2300
sta missle+1
lda #>$2400
sta player
lda #<$2400
sta player+1
lda #$00
sta length
lda #$01
sta length+1
lda #>2048
sta bufsiz
lda #<2048
sta bufsiz+1
jmp pmisvb
;
pmc lda sdmctl
ora #$0c
sta sdmctl
lda gractl
ora #$03
sta gractl
;
lda #>$2180
sta missle
lda #<$2180
sta missle+1
lda #>$2200
sta player
lda #<$2200
sta player+1
lda #$80
sta length
lda #$0
sta length+1
lda #>1024
sta bufsiz
lda #<1024
sta bufsiz+1
;
pmisvb equ *
lda #$07
ldx #<vblank
ldy #>vblank
jsr setvbv
lda #$1
sta vbflag
jmp pmibag
;
pmoff equ *
lda #0
sta gractl
sta $d00d
sta $d00e
sta $d00f
sta $d010
sta $d011
lda sdhold
sta sdmctl
sta $d400
lda #$07
ldy vhold
ldx vhold+1
jsr setvbv
jmp pmibag
missle dw 0
player dw 0
length dw 0
bufsiz dw 0
vbflag db 0
colreg db 0,0,0,0,40,202,148,70,0
posreg db 0,0,0,0
misreg db 0,0,0,0
sizrgp db 0,0,0,0
sizrgm db 0
rolreg db 0,0,0,0
pmibag equ *
ldx _t
#
end;
procedure clear_pm_buffer(resolution:integer);
begin
if resolution=1 then
resolution:=0
else
resolution:=1;
#a
lda #$0
sta vbflag
ldy #$5
lda (_sp),y
sta _t
ldy #$ff
cpbl lda #0
sta $2000,y
sta $2100,y
sta $2200,y
sta $2300,y
lda _t
bne cpbv
sta $2400,y
sta $2500,y
sta $2600,y
sta $2700,y
cpbv dey
cpy #$ff
bne cpbl
lda #$01
sta vbflag
#
end;
procedure player_width(player,width:integer);
begin
#a
lda #0
sta vbflag
ldy #5
lda (_sp),y
pha
ldy #7
lda (_sp),y
tay
pla
sta sizrgp,y
lda #1
sta vbflag
#
end;
procedure missle_width(missle,width:integer);
begin
#a
lda #0
sta vbflag
ldy #5
lda (_sp),y
pha
iny
iny
lda (_sp),y
tay
pla
beq mwe
mwl asl
asl
dey
bne mwl
mwe sta sizrgm
lda #1
sta vbflag
#
end;
procedure pmcolor(player,color:integer);
begin
#a
lda #0
sta vbflag
ldy #5
lda (_sp),y
pha
iny
iny
lda (_sp),y
tay
pla
sta colreg,y
lda #1
sta vbflag
#
end;
procedure hitclear;
begin
#a
lda #0
sta hitclr
#
end;
procedure horiz_player_pos(player,position:integer);
begin
#a
ldy #$05
lda (_sp),y
pha
ldy #$07
lda (_sp),y
tay
pla
sta posreg,y
#
end;
procedure horiz_missle_pos(missle,position:integer);
begin
#a
ldy #$05
lda (_sp),y
pha
ldy #$07
lda (_sp),y
tay
pla
sta misreg,y
#
end;
procedure putshape(player,offset,length:integer; var shape:pmarray);
begin
#a
lda #0
sta vbflag
ldy #5
lda (_sp),y ;pick up pointer
sta _t ;to data buffer.
iny
lda (_sp),y
sta _t+1
iny
lda (_sp),y ;pick up length
pha
ldy #09
clc
lda (_sp),y ;pick up offset
adc #>$2000
sta _t+2
lda #0 ;offset always<256
adc #<$2000
sta _t+3
ldy #11
lda (_sp),y ;pick up player #
asl
tay
lda length
beq single
clc
lda dlroff,y
adc _t+2
sta _t+2
lda dlroff+1,y
adc _t+3
sta _t+3
jmp psdoit
;
slroff dw $0400,$0500,$0600,$0700
dlroff dw $0200,$0280,$0300,$0380
;
single clc
lda slroff,y
adc _t+2
sta _t+2
lda slroff+1,y
adc _t+3
sta _t+3
;
psdoit pla
tay
dey
pslop2 lda (_t),y
sta (_t+2),y
dey
bpl pslop2
lda #1
sta vbflag
#
end;
procedure roll_player_buffer(player,roll:integer);
begin
#a
lda #0
sta vbflag
ldy #5
lda (_sp),y
pha
iny
iny
lda (_sp),y
tay
pla
clc
adc rolreg,y
sta rolreg,y
lda #1
sta vbflag
#
end;
procedure put_missle(missle,offset,length:integer; var shape:pmarray);
begin
#a
lda #0
sta vbflag
ldy #5
lda (_sp),y ;pick up pointer
sta _t ;to data buffer.
iny
lda (_sp),y
sta _t+1
iny
lda (_sp),y ;pick up length
pha
ldy #09
clc
lda (_sp),y ;pick up offset
adc missle
sta _t+2
lda #0 ;offset always<256
adc missle+1
sta _t+3
ldy #11
lda (_sp),y
stx _t+4
tax
pla
tay
dey
pmloop lda (_t+2),y ;get missle data
and mmask,x ;mask unwanted bits
sta (_t+2),y
lda (_t),y
and nmask,x
ora (_t+2),y
sta (_t+2),y
dey
bpl pmloop
ldx _t+4
lda #1
sta vbflag
#
end;
#a
mmask db $fc,$f3,$cf,$3f
nmask db $03,$0c,$30,$c0
#
function player_to_pf(player:integer):integer;
begin
player_to_pf:=0;
#a
ldy #7
lda (_sp),y
tay
lda p0pf,y
ldy #5
sta (_sp),y
#
end;
function player_to_pl(player:integer):integer;
begin
player_to_pl:=0;
#a
ldy #7
lda (_sp),y
tay
lda p0pl,y
ldy #5
sta (_sp),y
#
end;
function missle_to_pf(missle:integer):integer;
begin
missle_to_pf:=0;
#a
ldy #7
lda (_sp),y
tay
lda m0pf,y
ldy #5
sta (_sp),y
#
end;
function missle_to_pl(missle:integer):integer;
begin
missle_to_pl:=0;
#a
ldy #7
lda (_sp),y
tay
lda m0pl,y
ldy #5
sta (_sp),y
#
end;
procedure wait;
begin
#a
lda #1
sta waitfl
w.back equ *
lda waitfl
bne w.back
#
end;
procedure priority(x:integer);
begin
#a
ldy #5
lda (_sp),y
sta $d01b
#
end;
#a
waitfl db 0
vblank lda vbflag
bne *+5
jmp xitvbv
ldy #8
vbck1 lda colreg,y
sta pcolr0,y
dey
bpl vbck1
ldy #12
vbk2 lda posreg,y
sta hposp0,y
dey
bpl vbk2
;
ldy #$3
ldx vbkx
vbk3 sty vbky
ldy rolreg,x
bne doplay
dex
bpl saveit
ldx #$3
saveit stx vbkx
ldy vbky
dey
bpl vbk3
vnext lda #0
sta waitfl
jmp xitvbv
;
doplay stx vbkx
txa
asl
tax
clc
lda length
beq vbk4
lda dlroff,x
adc #>$2000
sta _t+14
lda dlroff+1,x
adc #<$2000
sta _t+15
jmp vbk5
;
vbk4 lda slroff,x
adc #>$2000
sta _t+14
lda slroff+1,x
adc #<$2000
sta _t+15
;
vbk5 tya
tax
ldy #0
vbk6 cpx length
bne vbk7
ldx #0
vbk7 lda (_t+14),y
sta vbktmp,x
iny
inx
cpy length
bne vbk6
;
ldy #0
vbk8 lda vbktmp,y
sta (_t+14),y
iny
cpy length
bne vbk8
ldx vbkx
lda #0
sta rolreg,x
jmp vnext
;
xtemp db 0
vbkx db 3
vbky db 0
vbktmp ds 256
#
No comments:
Post a Comment