home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Transactor
/
Transactor_21_1988_Transactor_Publishing.d64
/
potential.pal
(
.txt
)
< prev
next >
Wrap
Commodore BASIC
|
2023-02-26
|
4KB
|
304 lines
100 rem 'hires' circle - potential
110 rem source file by anthony bryant
120 sys 700
130 .opt n
140 ;
150 ;
160 ;"hires" variables by g.kiziak
170 x1 = $c027 ;current position
180 y1 = $c029
190 x2 = $c02b ;new position
200 y2 = $c02d
210 xc = $c02f ;circ centre (also box)
220 yc = $c031
230 hm = $c035 ;hires/multi flag
240 ;
250 ;
260 ;"hires" internal subroutines
270 igeti =$c17c ;internal get integer
280 ieget =$c187 ;internal eat & get x,y
290 move =$c26e ;'move' rtn
300 imov =$c271 ;internal moveto x1,y1
310 iplt =$c375 ;internal plot
320 idrw =$c42b ;internal drawto
330 ;
340 ;zero page labels
350 t1 = $22
360 t2 = $24
370 flag = $26
380 x = $27
390 y = $29
400 phi = $57
410 phiy = $59
420 phixy = $5b
430 ;
440 *=$8000 ;545 bytes
450 ;
460 xr .wor 0 ;x radius
470 yr .wor 0 ;y radius
480 x3 .wor 0 ;potential y
490 y3 .wor 0 ;potential x
500 ;
510 ;subroutine moveto xc,yc
520 movc ldx #3
530 lda x2,x
540 sta xc,x
550 dex
560 bpl movc+2
570 rts
580 ;
590 ;subroutine moveto xr,yr
600 movr ldx #3
610 lda x2,x
620 sta xr,x
630 dex
640 bpl movr+2
650 rts
660 ;
670 ;sys circle,xc,yc,xr,yr
680 circle = *
690 jsr ieget
700 jsr movc ;moveto xc,yc
710 jsr ieget
720 jsr movr ;moveto xr,yr
730 lda #0
740 sta flag
750 sta phi
760 sta phi+1
770 sta y
780 sta y+1
790 ;
800 cases lda xr
810 sta x ;x=xr
820 cmp yr
830 lda xr+1
840 sta x+1
850 sbc yr+1
860 bcs loop ;branch if xr >= yr
870 swap lda #$ff
880 sta flag
890 lda yr
900 sta x
910 tax ;x=yr
920 lda yr+1
930 sta x+1
940 tay ;and swap
950 lda xr
960 sta yr
970 stx xr ; xr with yr
980 lda xr+1
990 sta yr+1
1000 sty xr+1
1010 ;
1020 loop = * ;main loop start
1030 ldx y+1
1040 stx phiy+1
1050 lda y
1060 asl ;phiy=phi+y+y+1
1070 rol phiy+1
1080 sec
1090 adc phi
1100 sta phiy
1110 lda phiy+1
1120 adc phi+1
1130 sta phiy+1
1140 ldx x+1
1150 stx phixy+1
1160 lda x
1170 asl ;phixy=phiy-x-x+1
1180 rol phixy+1
1190 sta phixy
1200 clc
1210 lda phiy
1220 sbc phixy
1230 sta phixy
1240 lda phiy+1
1250 sbc phixy+1
1260 sta phixy+1
1270 ;
1280 lda x
1290 ldx x+1
1300 ldy flag
1310 bmi altn
1320 sta x2
1330 stx x2+1
1340 jsr scale
1350 sta y3
1360 stx y3+1
1370 lda y
1380 ldx y+1
1390 sta x3
1400 stx x3+1
1410 jsr scale
1420 sta y2
1430 stx y2+1
1440 jmp doplt
1450 altn sta y3
1460 stx y3+1
1470 jsr scale
1480 sta x2
1490 stx x2+1
1500 lda y
1510 ldx y+1
1520 sta y2
1530 stx y2+1
1540 jsr scale
1550 sta x3
1560 stx x3+1
1570 ;
1580 doplt jsr plot4
1590 lda x3
1600 ldx x3+1
1610 sta x2
1620 stx x2+1
1630 lda y3
1640 ldx y3+1
1650 sta y2
1660 stx y2+1
1670 jsr plot4
1680 ;
1690 inc y
1700 bne j1
1710 inc y+1 ;y=y+1
1720 j1 lda phiy
1730 ldx phiy+1 ;phi=phiy
1740 sta phi
1750 stx phi+1
1760 abs1 jsr absv ;take abs(phiy)
1770 sta t2
1780 stx t2+1
1790 lda phixy
1800 ldx phixy+1
1810 abs2 jsr absv ;take abs(phixy)
1820 sta t1
1830 stx t1+1
1840 ;
1850 doif lda t1 ;if abs(phixy)
1860 cmp t2 ; < abs(phiy)
1870 lda t1+1
1880 sbc t2+1 ;then ...
1890 bcs else ;else ...
1900 then lda phixy
1910 ldx phixy+1
1920 sta phi
1930 stx phi+1 ;phi=phixy
1940 lda x
1950 bne j2
1960 dec x+1
1970 j2 dec x ;x=x-1
1980 else lda x ;if x >= y
1990 cmp y ;then loop
2000 lda x+1
2010 sbc y+1
2020 bcc stop ;else stop
2030 jmp loop
2040 stop rts
2050 ;
2060 ;subroutine reflect points & plot
2070 plot4 = *
2080 lda xc
2090 clc
2100 adc x2
2110 sta x1
2120 pha
2130 lda xc+1
2140 adc x2+1
2150 sta x1+1
2160 pha
2170 lda yc
2180 clc
2190 adc y2
2200 sta y1
2210 lda yc+1
2220 adc y2+1
2230 sta y1+1
2240 jsr iplt
2250 lda xc
2260 sec
2270 sbc x2
2280 sta x1
2290 lda xc+1
2300 sbc x2+1
2310 sta x1+1
2320 jsr iplt
2330 lda yc
2340 sec
2350 sbc y2
2360 sta y1
2370 lda yc+1
2380 sbc y2+1
2390 sta y1+1
2400 jsr iplt
2410 pla
2420 sta x1+1
2430 pla
2440 sta x1
2450 jmp iplt
2460 ;
2470 ;subroutine absolute value
2480 absv bpl abok
2490 clc
2500 eor #$ff
2510 adc #1
2520 pha
2530 txa
2540 eor #$ff
2550 adc #0
2560 tax
2570 pla
2580 abok rts
2590 ;
2600 ;subroutine to scale offset
2610 scale = * ;t1=t2*yr/xr
2620 sta t2
2630 stx t2+1
2640 lda #0
2650 sta t1
2660 sta t1+1
2670 ldx #17
2680 clc ;16 bit integer math
2690 mullp ror t1+1
2700 ror t1
2710 ror t2+1
2720 ror t2
2730 bcc decn1
2740 clc
2750 lda yr
2760 adc t1
2770 sta t1
2780 lda yr+1
2790 adc t1+1
2800 sta t1+1
2810 decn1 dex
2820 bne mullp
2830 lda xr
2840 ora xr+1
2850 beq error
2860 lda #0
2870 sta t1
2880 sta t1+1
2890 ldx #16 ;16 bit integer math
2900 divlp rol t2
2910 rol t2+1
2920 rol t1
2930 rol t1+1
2940 sec
2950 lda t1
2960 sbc xr
2970 tay
2980 lda t1+1
2990 sbc xr+1
3000 bcc decn2
3010 sty t1
3020 sta t1+1
3030 decn2 dex
3040 bne divlp
3050 rol t2
3060 rol t2+1
3070 lda t2
3080 ldx t2+1
3090 rts
3100 error jmp $bb8a ;"division by zero"
3110 ;
3120 .end