Transactor/Transactor_26_1988_Transactor_Publishing.d64/input.src

Commodore BASIC | 2023-02-26 | 9KB | 476 lines

1000 sys 700
1010 .opt oo
1020 ;
1030 ; ***********************
1040 ; *                     *
1050 ; *  m/l input routine  *
1060 ; *   (NULL)right 1987    *
1070 ; *   garry g. kiziak   *
1080 ; *                     *
1090 ; ***********************
1100 ;
1110 *=$c000 ; origin of routines
1120 ;
1130 ; command jump table
1140 ;
1150 jmp print ; print at routine
1160 jmp input ; input routine
1170 ;
1180 ; get cursor position
1190 ;
1200 chkcom = $aefd ; check for a comma
1210 combyt = $b7f1 ; get a byte in x
1220 illqty = $b248 ; illegal quantity
1230 plot = $fff0 ; set/read cursor position
1240 xval .byte 0 ; temporary storage
1250 yval .byte 0 ; temporary storage
1260 ;
1270 getcur jsr combyt ; get column
1280 cpx #$28 ; 0<=x<=39
1290 bcs set1 ; too big
1300 stx yval
1310 txa
1320 pha
1330 jsr combyt ; get row
1340 cpx #$19 ; 0<=y<=24
1350 bcs set1 ; too big
1360 stx xval
1370 pla
1380 tay
1390 clc
1400 jmp plot ; set cursor
1410 set1 jmp illqty
1420 ;
1430 ; print at routine
1440 ;
1450 print jsr getcur
1460 jsr chkcom
1470 jmp $aaa4 ; continue with rom print
1480 ;
1490 ; wait for a keystroke
1500 ;
1510 getin = $ffe4 ; check for a keypress
1520 beg = $fb ; beginning of input field
1530 curpos = $fd ; cursor position within input field
1540 ;
1550 getkey lda ir ; get character under cursor
1560 eor #$80 ; reverse it
1570 sta ir
1580 ldy curpos ; get cursor position
1590 sta (beg),y
1600 lda #$10 ; initialize counter
1610 sta count2
1620 lda #$ff
1630 sta count1
1640 get1 jsr getin ; has a key been pressed
1650 bne get2 ; yes
1660 dec count1 ; count down
1670 bne get1 ; try again
1680 dec count2 ; count down some more
1690 bne get1 ; try again
1700 beq getkey ; flash cursor
1710 get2 rts
1720 count1 .byte 0 ; counter for flashing cursor
1730 count2 .byte 0
1740 ;
1750 ; input routine
1760 ;
1770 len = $02 ; max. no. of characters allowed
1780 ast = $03 ; address of input string
1790 lenb = $b2 ; length of optional string
1800 bst = $b3 ; address of optional string
1810 varadr = $05 ; address of variable
1820 findvar = $b08b ; find variable
1830 justf .byte 0 ; justify flag
1840 escflg .byte 0 ; escape flag
1850 iq .byte 0 ; character being entered
1860 ir .byte 0 ; character under cursor
1870 id .byte 0 ; mask for allowable inpputs
1880 ;
1890 input lda #$00
1900 sta justf ; no justfication
1910 jsr getcur ; get cursor position
1920 clc
1930 lda $d1 ; get screen address
1940 adc $d3 ; for beginning of input
1950 sta beg
1960 lda $d2
1970 adc #$00
1980 sta beg+1
1990 jsr chkcom
2000 jsr findvar ; find input variable
2010 sta varadr ; save its location
2020 sty varadr+1
2030 ldy #$02 ; move its descriptor
2040 inp1 lda (varadr),y ; to zero page
2050 sta len,y
2060 dey
2070 bpl inp1
2080 lda len
2090 beq set1
2100 jsr combyt ; get max length of input
2110 txa
2120 beq set1
2130 cpx len ; bigger than length of string
2140 beq inp1a
2150 bcc inp1a
2160 bcs set1 ; yes, too big
2170 inp1a stx len
2180 jsr combyt ; get id
2190 stx id
2200 txa ; set status registers
2210 bpl inp1c ; no optional string
2220 jsr chkcom
2230 jsr findvar ; find optional string
2240 ldy #$02
2250 inp1b lda ($47),y ; get descriptor for string
2260 sta lenb,y
2270 dey
2280 bpl inp1b
2290 inp1c jsr priast ; print default input
2300 inp1d lda #$00
2310 sta $c6 ; clear keyboard buffer
2320 sta curpos ; initial position of cursor
2330 sta escflg ; escape flag = 0
2340 inp2 ldy curpos
2350 lda (beg),y ; get character under the cursor
2360 sta iq ; save it
2370 sta ir ; temporarily
2380 inp3 jsr getkey ; get a keypress
2390 sta $d7 ; save it temporarily
2400 cmp #133 ; [f1]
2410 bne inp4
2420 lda id
2430 and #16 ; check id
2440 beq inp3 ; not allowed
2450 lda iq
2460 ldy curpos ; restore character under cursor
2470 sta (beg),y
2480 ldx #$1 ; set escape flg
2490 stx escflg
2500 jmp return
2510 inp4 cmp #32 ; [space]
2520 beq inp5
2530 cmp #160 ; [shifted-space]
2540 bne inp6
2550 inp5 lda #32 ; convert to a normal space
2560 sta $d7
2570 jmp (NULL)tit
2580 inp6 cmp #48 ; [0]
2590 bcc inp7
2600 cmp #58 ; [9]+1
2610 bcs inp7
2620 lda id
2630 and #2 ; check id
2640 beq inp12 ; not allowed
2650 jmp (NULL)tit ; [0-9]
2660 inp7 cmp #65 ; [a]
2670 bcc inp8a
2680 cmp #91 ; [z]+1
2690 bcs inp8a
2700 inp8 lda id
2710 and #1 ; check id
2720 beq inp12 ; not allowed
2730 jmp (NULL)tit ; [a-z] or [shift a-shift z]
2740 inp8a cmp #193 ; [shift a]
2750 bcc inp9
2760 cmp #219 ; [shift z]+1
2770 bcs inp9
2780 bcc inp8
2790 inp9 cmp #157 ; [cursor left]
2800 bne inp10
2810 ldy curpos
2820 beq inp3 ; can't cursor left
2830 lda iq
2840 sta (beg),y
2850 dec curpos
2860 jmp inp2
2870 inp10 cmp #29 ; [cursor right]
2880 bne inp11
2890 ldy curpos
2900 iny
2910 cpy len
2920 beq inp3 ; can't cursor right
2930 dey
2940 lda iq
2950 sta (beg),y
2960 jsr check
2970 inc curpos
2980 jmp inp2
2990 inp11 cmp #13 ; [return]
3000 beq return
3010 cmp #17 ; [cursor down]
3020 beq down
3030 cmp #145 ; [cursor up]
3040 beq up
3050 cmp #148 ; [insert]
3060 beq insert
3070 cmp #46 ; [.]
3080 beq decimal
3090 cmp #20 ; [delete]
3100 bne inp12
3110 jmp delete
3120 inp12 bit id ; special characters allowed
3130 bpl done ; no
3140 ldy #$00
3150 lda $d7
3160 inp13 cmp (bst),y ; yes
3170 bne inp14
3180 jmp (NULL)tit
3190 inp14 iny
3200 cpy lenb
3210 bne inp13
3220 done jmp inp3 ; no other keys allowed
3230 up ldx #$03
3240 .byte $2c
3250 down ldx #$02
3260 lda id
3270 and #8
3280 beq done
3290 .byte $2c
3300 return ldx #$01
3310 lda id
3320 and #64
3330 beq ret1
3340 jsr justr
3350 ret1 ldy curpos
3360 lda iq
3370 sta (beg),y
3380 lda id
3390 and #32 ; check for removing trailing spaces
3400 beq ret4 ; no
3410 ldy len
3420 dey
3430 ret2 lda (ast),y ; get character from a$
3440 cmp #32 ; is it a space
3450 bne ret3
3460 dey
3470 bpl ret2
3480 ret3 iny
3490 tya
3500 ldy #$00
3510 sta (varadr),y
3520 ret4 txa ; type of return in location 780
3530 pha
3540 jsr priast
3550 pla
3560 ldx escflg ; get escape flag
3570 rts
3580 decimal lda id ; check id
3590 and #4
3600 beq inp12 ; not allowed
3610 jsr checkd ; check for decimal point
3620 beq cant ; decimal point already entered
3630 jmp (NULL)tit
3640 cant jmp inp3
3650 insert ldy curpos
3660 lda iq
3670 sta (beg),y
3680 ldy len
3690 dey
3700 cpy curpos
3710 beq cant
3720 lda (ast),y
3730 cmp #32 ; is last character a space
3740 bne cant ; can't insert
3750 ins1 dey
3760 lda (beg),y ; get screen code
3770 pha ; save it
3780 lda (ast),y
3790 iny
3800 sta (ast),y ; move character in string
3810 pla
3820 sta (beg),y ; move character on screen
3830 dey
3840 cpy curpos
3850 bne ins1
3860 lda #32
3870 sta (ast),y ; put space in string
3880 ldx $c7
3890 beq ins2
3900 ora #$80
3910 ins2 sta (beg),y ; put space on screen
3920 jmp inp2
3930 delete ldy curpos
3940 bne del1
3950 iny ; cursor in first position
3960 cpy len ; only one character
3970 bne cant ; no, so can't delete
3980 dey ; yes, so put a space
3990 lda #32 ; in the first position
4000 sta (beg),y
4010 sta (ast),y
4020 jmp inp2
4030 del1 lda iq
4040 sta (beg),y
4050 iny ; is cursor on last character
4060 cpy len
4070 bne del2 ; no
4080 dey ; yes
4090 lda (ast),y ; get last character
4100 cmp #32 ; is it a space
4110 beq del2 ; yes
4120 inc curpos ; no
4130 del2 ldy curpos
4140 dey
4150 lda (ast),y ; get character to delete
4160 del3 iny
4170 cpy len
4180 beq del5
4190 lda (ast),y ; character to replace
4200 pha
4210 lda (beg),y
4220 dey
4230 ldx $c7
4240 beq del4
4250 ora #$80
4260 del4 sta (beg),y ; delete it on screen
4270 pla
4280 sta (ast),y ; delete it in string
4290 iny
4300 bne del3
4310 del5 dey
4320 lda #32
4330 sta (ast),y
4340 ldx $c7
4350 beq del6
4360 ora #$80
4370 del6 sta (beg),y
4380 dec curpos
4390 jmp inp2
4400 (NULL)tit jsr check
4410 ldy curpos
4420 lda $d7
4430 sta (ast),y ; put it in string
4440 bmi (NULL)t3
4450 cmp #$60
4460 bcc (NULL)t1
4470 and #$df
4480 bne (NULL)t2
4490 (NULL)t1 and #$3f
4500 (NULL)t2 jmp (NULL)t5
4510 (NULL)t3 and #$7f
4520 cmp #$7f
4530 bne (NULL)t4
4540 lda #$5e
4550 (NULL)t4 ora #$40
4560 (NULL)t5 ldx $c7
4570 beq (NULL)t6
4580 ora #$80
4590 (NULL)t6 sta (beg),y
4600 iny
4610 cpy len
4620 bne (NULL)t7
4630 dey
4640 (NULL)t7 sty curpos
4650 jmp inp2
4660 ;
4670 ; justify left
4680 ;
4690 tempm .byte 0
4700 tempn .byte 0
4710 ;
4720 justl ldy #$00
4730 sty tempm
4740 lda (ast),y
4750 cmp #32
4760 bne jus5 ; already justified
4770 jus1 iny
4780 cpy len
4790 beq jus5 ; all spaces
4800 lda (ast),y
4810 cmp #32
4820 beq jus1
4830 sty tempn ; first non-space character
4840 jus2 ldy tempm ; move left
4850 sta (ast),y
4860 inc tempn
4870 inc tempm
4880 ldy tempn
4890 cpy len
4900 beq jus3
4910 lda (ast),y
4920 bne jus2
4930 beq jus2
4940 jus3 ldy tempm ; rest are spaces
4950 lda #32
4960 jus4 sta (ast),y
4970 iny
4980 cpy len
4990 bcc jus4
5000 jus5 rts
5010 ;
5020 ; justify right
5030 ;
5040 justr ldy len
5050 dey
5060 sty tempm
5070 lda (ast),y
5080 cmp #32
5090 bne just5 ; already justified
5100 just1 dey
5110 bmi just5 ; all spaces
5120 lda (ast),y
5130 cmp #32
5140 beq just1
5150 sty tempn ; first non-space characterady.
5160 just2 ldy tempm
5170 sta (ast),y
5180 dec tempm
5190 dec tempn
5200 ldy tempn
5210 bmi just3
5220 lda (ast),y
5230 bne just2
5240 beq just2
5250 just3 ldy tempm ; rest are spaces
5260 lda #32
5270 just4 sta (ast),y
5280 dey
5290 bpl just4
5300 just5 rts
5310 ;
5320 ; print string
5330 ;
5340 priast lda $d7
5350 pha
5360 ldy yval
5370 ldx xval
5380 clc
5390 jsr plot
5400 ldy #$00
5410 pri1 lda (ast),y
5420 jsr $ffd2
5430 iny
5440 cpy len
5450 bne pri1
5460 pla
5470 sta $d7
5480 rts
5490 ;
5500 ; check justify flag
5510 ;
5520 check bit justf
5530 bmi ch1 ; already on
5540 lda id
5550 and #64
5560 beq ch1 ; not allowed
5570 jsr justl ; justify string and
5580 jsr priast ; print it
5590 lda #$80 ; set flag
5600 sta justf
5610 ch1 rts
5620 ;
5630 ; check for decimal
5640 ;
5650 checkd ldy len
5660 dey
5670 check1 lda (ast),y
5680 cmp #46
5690 beq check2 ; found one
5700 dey
5710 bpl check1
5720 lda #$01 ; no decimal point
5730 check2 rts
0