Transactor/Transactor_18_1987_Transactor_Publishing.d64/array.src

Commodore BASIC | 2023-02-26 | 10KB | 483 lines

1 ;array math functions
2 ;c richard richmond
3 ; 308 rosewood ave.
4 ; springfield, ohio
5 ; 45506
6 ; [phone]
10 org $ca58
20 :memfac .eq $bba2  ;memory to fac1
30 :facmem .eq $bbd4  ;fac1 to memory
40 :compar .eq $bc5b  ;compare memory to fac1
80 :memplu .eq $b867  ;add memory to fac1
90 :memmul .eq $ba28  ;mult fac1 by memory
100 :memsub .eq $b850 ;sub fac1 from memory
110 :memdiv .eq $bb0f ;divide fac1 by memory
120 jmp :eqv ; a()=v 'starting address
130 jmp :eqb ; a()=b() 'sa+3
140 jmp :plv ; a()=a()+v 'sa+6
150 jmp :plb ; a()=a()+b() 'sa+9
160 jmp :sbv ; a()=a()-v 'sa+12
170 jmp :sbb ; a()=a()-b() 'sa+15
180 jmp :mlv ; a()=a()*v 'sa+18
190 jmp :mlb ; a()=a()*b() 'sa+21
200 jmp :dvv ; a()=a()/v 'sa+24
210 jmp :dvb ; a()=a()/b() 'sa+27
220 jmp :bsv ; a()=v-a() 'sa+30
230 jmp :bsb ; a()=b()-b() 'sa+33
240 jmp :vdv ; a()=v/a() 'sa+36
250 jmp :vdb ; a()=b()/a() 'sa+39
260 jmp :max ; v=max(a()) 'sa+42
270 jmp :min ; v=min(a()) 'sa+45
275 jmp :square ; a()=a()^2 'sa+48
277 jmp :insert ; insert v at a() 'sa+51
280 :dummy
290 .ds$0006
320 :zpage
330 .ds $000d
340 :szpage    ; routine to save
350 ldy #$0c   ; zero page memory
360 :sz1
370 lda $00bf,y
380 sta :zpage,y
390 dey
400 bpl :sz1
410 rts
420 :reset        ;routine to reset
430 ldy #$0c      ;aero page memory
440 :restorez
450 lda :zpage,y
460 sta $00bf,y
470 dey
480 bpl :restorez
490 rts           ;exit
500 :store        ;store fac1
510 ldx $b5       ;to memory
520 ldy $b6       ; specified at
530 jsr :facmem   ; $b5,$b6
540 rts
550 :test1   ;this portion
560 lda $b7  ;increments the
570 clc      ;second array
580 adc #$05 ;pointers by
590 sta $b7  ;5
600 lda $b8
610 adc #$00
620 sta $b8
630 :test   ;routine to
640 lda $b9 ;increment
650 clc     ;first array
660 adc #$05 ;pointers by
670 sta $b9  ;5
680 lda $ba
690 adc #$00
700 sta $ba
710 :test2    ;and check
720 cmp $fc   ;for the end
730 bne :cont ;of array
740 lda $b9
750 cmp $fb
760 bne :cont
770 clc
780 rts
790 :cont  ;if not to end
800 sec    ;set carry bit
810 rts
820 :eqv  ;a()=v
830 jsr :szpage ;store zero page
840 jsr :mod1   ;get addresses
850 lda $b7     ;address o
860 ldy $b8     ;v
870 jsr :memfac ;load v to fac1
880 :eqv1
890 ldx $b9     ;address of
900 ldy $ba     ;a()
910 jsr :facmem ;fac1 to a(x)
920 jsr :test   ;check if done
930 bcs :eqv1   ;no continue
940 jmp :reset  ;yes exit routine
950 :plv        ;a()=a()+v
960 jsr :szpage
970 jsr :mod1
980 :plv2
990 lda $b9     ;load address
1000 ldy $ba    ;of next a()
1010 sta $b5    ;pointer for
1020 sty $b6    ;store routine
1030 jsr :memfac;1st element to fac1
1040 lda $b7    ;address of
1050 ldy $b8    ;v
1060 jsr :memplu ;add v to fac1
1070 jsr :store  ;results to a()
1080 jsr :test
1090 bcs :plv2
1100 jmp :reset
1110 :sbv        ;a()=a()-v
1120 jsr :szpage
1130 jsr :mod1
1140 :sbv1
1150 lda $b7    ;load address
1160 ldy $b8    ;of v
1170 jsr :memfac ;v to fac1
1180 lda $b9    ;load address
1190 sta $b5    ;of
1200 ldy $ba    ;a()
1210 sty $b6
1220 jsr :memsub ;a()added to fac1
1230 jsr :store  ;result to a()
1240 jsr :test
1250 bcs :sbv1
1260 jmp :reset
1270 :bsv   ;a()=v-a()
1280 jsr :szpage
1290 jsr :mod1
1300 :bsv1
1310 lda $b9
1320 sta $b5
1330 ldy $ba
1340 sty $b6
1350 jsr :memfac ;fac1=a()
1360 lda $b7     ;address
1370 ldy $b8     ;of v
1380 jsr :memsub ;fac1=v-a()
1390 jsr :store  ;a()=fac1
1400 jsr :test
1410 bcs :bsv1
1420 jmp :reset
1430 :mlv        ;a()=a()*v
1440 jsr :szpage
1450 jsr :mod1
1460 :mlv1
1470 lda $b9
1480 sta $b5      ;address
1490 ldy $ba      ;of a()
1500 sty $b6
1510 jsr :memfac  ;fac1=a()
1520 lda $b7      ;address
1530 ldy $b8      ;of v
1540 jsr :memmul  ;fac1=a()*v
1550 jsr :store   ;a()=fac1
1560 jsr :test
1570 bcs :mlv1
1580 jmp :reset
1590 :dvv         ;a()=a()/v
1600 jsr :szpage
1610 jsr :mod1
1620 :dvv1
1630 lda $b7      ;adress
1640 ldy $b8      ;of v
1650 jsr :memfac  ;fac1=v
1660 lda $b9      ;address
1670 sta $b5      ;of a()
1680 ldy $ba
1690 sty $b6
1700 jsr :memdiv  ;fac1=a()/v
1710 jsr :store   ;a()=fac1
1720 jsr :test
1730 bcs :dvv1
1740 jmp :reset
1750 :vdv         ;a()=v/a()
1760 jsr :szpage
1770 jsr :mod1
1780 :vdv1
1790 lda $b9      ;address
1800 sta $b5      ;of a()
1810 ldy $ba
1820 sty $b6
1830 jsr :memfac  ;fac1=a()
1840 lda $b7      ;address
1850 ldy $b8      ;of v
1860 jsr :memdiv  ;fac1=v/fac1
1870 jsr :store   ;a()=fac1
1880 jsr :test
1890 bcs :vdv1
1900 jmp :reset
1910 :plb         ;a()=a()*b()
1920 jsr :szpage
1930 jsr :mod1
1940 :plb1
1950 lda $b7      ;address
1960 ldy $b8      ;of b()
1970 jsr :memfac  ;fac1=b()
1980 lda $b9
1990 sta $b5      ;address
2000 ldy $ba      ;of a()
2010 sty $b6
2020 jsr :memplu  ;fac1=fac1*a()
2030 jsr :store   ;a()=fac1
2040 jsr :test1   ;increment b pointer then a
2050 bcs :plb1
2060 jmp :reset
2070 :sbb        ;a()=a()-b()
2080 jsr :szpage
2090 jsr :mod1
2100 :sbb1
2110 lda $b7     ;address
2120 ldy $b8     ;of b()
2130 jsr :memfac ;fac1=b()
2140 lda $b9
2150 sta $b5     ;address
2160 ldy $ba     ;of a()
2170 sty $b6
2180 jsr :memsub ;fac1=a()-fac1
2190 jsr :store  ;a()=1
2200 jsr :test1  ;increment b then a
2210 bcs :sbb1
2220 jmp :reset
2230 :mlb       ;a()=a()*b()
2240 jsr :szpage
2250 jsr :mod1
2260 :mlb1
2270 lda $b7    ;address
2280 ldy $b8    ;of b()
2290 jsr :memfac ;fac1=b()
2300 lda $b9
2310 sta $b5    ;address
2320 ldy $ba    ;of a()
2330 sty $b6
2340 jsr :memmul ;fac1=fac1*a()
2350 jsr :store  ;a()=fac1
2360 jsr :test1  ;increment pointers
2370 bcs :mlb1
2380 jmp :reset
2390 :dvb        ;a()=a()/b()
2400 jsr :szpage
2410 jsr :mod1
2420 :dvb1
2430 lda $b7     ;address
2440 ldy $b8     ;of b()
2450 jsr :memfac ;fac1=b()
2460 lda $b9
2470 sta $b5     ;address
2480 ldy $ba     ;of a()
2490 sty $b6
2500 jsr :memdiv ;fac1=fac1*a()
2510 jsr :store  ;a()=fac1
2520 jsr :test1  ;increment pointers
2530 bcs :dvb1
2540 jmp :reset
2550 :bsb        ;a()=b()-a()
2560 jsr :szpage
2570 jsr :mod1
2580 :bsb1
2590 lda $b9
2600 ldy $ba     ;address
2610 sta $b5     ;of a()
2620 sty $b6
2630 jsr :memfac ;fac1=a()
2640 lda $b7     ;address
2650 ldy $b8     ;of b()
2660 jsr :memsub ;fac1=b()-fac1
2670 jsr :store  ;a()=fac1
2680 jsr :test1  ;increment pointers
2690 bcs :bsb1
2700 jmp :reset
2710 :vdb        ;a()=b()/a()
2720 jsr :szpage
2730 jsr :mod1
2740 :vdb1
2750 lda $b9
2760 sta $b5     ;address
2770 ldy $ba     ;of a()
2780 sty $b6
2790 jsr :memfac ;fac1=a()
2800 lda $b7     ;address
2810 ldy $b8     ;of b()
2820 jsr :memdiv ;fac1=b()/fac1
2830 jsr :store  ;a()=fac1
2840 jsr :test1
2850 bcs :vdb1
2860 jmp :reset
2870 :eqb        ;a()=b()
2880 jsr :szpage
2890 jsr :mod1
2900 :eqb1
2910 ldy #$00
2920 lda ($b7),y  ;1st byte of b
2930 sta ($b9),y  ;into a
2940 inc $b7      ;increment
2950 bne :eqb2    ;address
2960 inc $b8      ;of b
2970 :eqb2
2980 inc $b9      ;increment
2990 bne  :eqb3   ;address
3000 inc $ba      ;of a
3010 :eqb3
3020 lda $ba      ;hi byte of a
3030 jsr :test2   ;end of array
3040 bcs :eqb1    ;no continue
3050 jmp :reset   ;yes exit routine
3060 :mod2        ;find address of a
3070 jsr $aefd    ;skip comma
3080 jsr $ad9e    ; routine
3090 lda $47      ;lo byte of
3100 sta $b9      ;a address
3110 lda $48      ;hi byte of
3120 sta $ba      ;a address
3130 lda $2f      ;start of
3140 sta $fb
3150 lda $30      ;array storage
3160 sta $fc
3170 :again       ;search array storage
3180 ldy #$00
3190 lda ($fb),y
3200 cmp $45      ;for name
3210 bne :step2   ;of
3220 iny
3230 lda ($fb),y
3240 cmp $46      ;'a' array
3250 bne :step    ;routine returns
3260 jsr :step1   ;with ending address
3270 rts          ;of a()in $fb,$fc
3280 :step2
3290 iny
3300 :step
3310 jsr :step1
3320 jmp :again
3330 :step1       ;routine to
3340 iny          ;skip through
3350 lda ($fb),y  ;array memory
3360 sta $fd      ;from one
3370 iny          ;array to next
3380 lda ($fb),y
3390 clc
3400 adc $fc
3410 sta $fc
3420 lda $fb
3430 clc
3440 adc $fd
3450 sta $fb
3460 bcc :st2
3470 inc $fc
3480 :st2
3490 rts
3500 :mod1     ;routine to find b()
3510 jsr $aefd ;skip comma
3520 jsr $b08b ; routine
3530 lda $47   ;to find v,b
3540 sta $b7   ;or create
3550 lda $48   ;variable
3560 sta $b8   ;if not found
3570 jmp :mod2
3580 :max        ;v=maximum of a()
3590 jsr :szpage
3600 jsr :mod1
3610 lda $b9
3620 ldy $ba
3630 jsr :memfac ;fac1=a(0)
3640 .xy :dummy  ;store in
3650 jsr :facmem ;'dummy'
3660 jsr :test
3670 :max2
3680 lda $b9     ;next address
3690 ldy $ba     ;of a()
3700 jsr :memfac ;fac1=a()
3710 .xy :dummy
3720 txa
3730 jsr :compar ;compare
3740 bmi :max3   ;a() with 'dummy'
3750 .xy :dummy  ;fac1 larger
3760 jsr :facmem ;then 'dummy'=fac1
3770 :max3
3780 jsr :test   ;done
3790 bcs :max2   ;no continue
3800 .xy :dummy  ;yes
3810 txa         ;fac1='dummy'
3820 jsr :memfac
3830 ldx $b7     ;address
3840 ldy $b8     ;of v
3850 jsr :facmem ;v=fac1
3860 jmp :reset
3870 :min        ;v=minimum of a()
3880 jsr :szpage
3890 jsr :mod1
3900 lda $b9    ;address
3910 ldy $ba    ;of a(0)
3920 jsr :memfac ;store
3930 .xy :dummy  ;a(0) into
3940 jsr :facmem ;'dummy'
3945 jsr :test
3950 :min2
3960 lda $b9     ;address of
3970 ldy $ba     ;next a()
3980 jsr :memfac ;load into fac1
3990 .xy :dummy  ;and
4000 txa
4010 jsr :compar ;compare with 'dummy'
4020 bpl :min3   ;fac1<'dummy
4030 .xy :dummy  ;then 'dummy'
4040 jsr :facmem ;=fac1
4050 :min3
4060 jsr :test
4070 bcs :min2   ;'dummy =min(a)
4080 .xy :dummy
4090 txa
4100 jsr :memfac ;transfer
4110 ldx $b7     ;'dummy'
4120 ldy $b8     ;to
4130 jsr :facmem ;v
4140 jmp :reset
4150 :square     ;a=a*a
4160 jsr :szpage
4170 jsr :mod2
4180 :squ1
4190 lda $b9     ;address
4200 ldy $ba     ;of a()
4210 sta $b5
4220 sty $b6
4230 jsr :memfac ;a() to fac1
4235 lda $b9
4237 ldy $ba
4240 jsr :memmul ;fac1=a*a
4250 jsr :store
4260 jsr :test   ;increment pointer
4270 bcs :squ1
4280 jmp :reset
4290 :insert     ;a(x)=v
4300 jsr :szpage ;following
4310 jsr :mod1   ;elements
4320 lda #$05    ;moved down
4330 sta $bf     ;a(max)=a(max-1)
4340 lda $46     ;continue
4350 asl a       ;until
4360 bcc :ins1   ;a(x+1)=a(x)
4370 lda #$02    ;then a(x)=v
4380 sta $bf     ;routine will
4390 :ins1       ;automatically
4400 lda $fb     ;use proper offset
4410 clc         ;for variable type
4420 sbc $bf     ;works with
4430 sta $fb     ;strings (a$)
4440 lda $fc     ;integers (a%)
4450 sbc #$00    ;or
4460 sta $fc     ;floating point
4470 lda $fb
4480 clc
4490 sbc $bf
4500 sta $fd
4510 lda $fc
4520 sbc #$00
4530 sta $fe
4540 ldy $bf
4550 dey
4560 :ins2
4570 lda ($fd),y
4580 sta ($fb),y
4590 dey
4600 bpl :ins2
4610 lda $fe
4620 cmp $ba
4630 bne :ins1
4640 lda $fd
4650 cmp $b9
4660 bne :ins1
4670 ldy $bf
4680 dey
4690 :ins3
4700 lda ($b7),y
4710 sta ($fb),y
4720 dey
4730 bpl :ins3
4740 jmp :reset
4750 :end
4760 .en