Transactor

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