;*****************************************************************************
;* Code for dBASE-callable machine-language subroutines.                     *
;* (c) 1983 by Bertel Schmitt POB 137 Charlottesville, VA 22902              *
;*             (804) 293 5197                                                *
;* The following routines are stand-alone, they assemble separately.         *
;* They are not an example for effective code, I am a business-man, not      *
;* a programmer. And most of my exposure to assembly comes from a            *
;* vintage RCA 1802 machine .....                                            *
;*                                                                           *
;* Cleanups and revisions will be greatly appreciated ...                    *
;*                                                                           *
;*         ++++++   WE  NEED MORE ROUTINES !!!!  ++++++                      *
;*                                                                           *
;*                                                                           *
;*                     Wish-list:                                            *
;* 1.) A date-input checker to weed-out things like "02/31/83" FAST!         *
;* 2.) A Gregorian to Julian  and v.v. routine.                              *
;* 3.) A rounding-routine for floating point variables.                      *
;*     Those truncated numbers are DRIVING MY CPA CRAZY !!!!                 *
;*                                                                           *
;*               START CODING AND LEAVE THE STUFF ON THIS SYSTEM!            *
;*                              B.S.                                         *
;*  P.S.: Pardon my English .... I'm German.....                             *

;*****************************************************************************




;*****************************************************************************
;
; THIS ROUTINE  RIGHT-JUSTIFIES THE CALLED DBASE-STRING 
;*****************************************************************************



TRUE	EQU	0FFFFH
FALSE	EQU	NOT TRUE


; SOME EQUATES

BLANK 	EQU	020H


	ORG 0A42EH ; OR WHEREVER YOU WANT IT ....

; POINTER TO VAR IS IN H,L
; WHICH POINTS TO LENGTH      


		MOV	C,L	;SAVE VARIABLE
		MOV	B,H	;POINTER
		LDAX	B	;LOAD LENGTH BYTE
		STA 	LENGTH ;AND STORE IT
		ADD	C	;ADD IT TO POINTER
		MOV	C,A
		MVI	A,00H	;ZERO ACCU
		ADC	B	;IN CASE OF A CARRY
		MOV	B,A	; B  POINTS TO LASTBYTE NOW
		MOV	D,B	; AND D, H TOO
		MOV	E,C
	;NOW DO THE WORK

LOOP:		LDAX	B	;GET BYTE
		XRI	BLANK	;IS IT A BLANK?
		CNZ	ADDBYT	;NOPE, SO STORE IT
		DCX	B	;DECREMENT POINTER
		LDA    	LENGTH ;LOAD LENGTH BYTE
		DCR	A	;DECREMENT
		STA 	LENGTH	 ;STORE LENGTH BYTE AWAY
		JZ      UPVAR   ;IF ZERO, RESTORE VAR
		JMP	LOOP	;AND DO IT AGAIN
UPVAR:		;NOW PAD THE REST OF THE VAR WITH BLANKS
	 	MOV 	A,E	;GET  STOREAWA POINTER
		SUB	L	;SUBTRACT VARPOINTER
	 	INR	A	;DEC 1 TO ADJUST
		STA 	LENGTH ;STORE

UPLOOP:		MVI 	A,BLANK 	;LOAD A BLANK
		CALL	ADD2		;STORE IN VAR
		DCX	B	;DECREMENT POINTER
		LDA 	LENGTH	 ;LOAD LENGTH BYTE
		DCR	A	;DECREMENT
		STA	LENGTH	; AND STORE
		JNZ	UPLOOP	; IF NOT DONE
		RET		; GO HOME


ADDBYT:		;STOREAWAY SUB
		LDAX	B	;GET CHAR
ADD2:		STAX	D	;STORE AWAY
		DCX	D	;DECREMENT POINTER
		RET		;AND RETURN
LENGTH		EQU	$
		DB	000H	;STORAGE FOR LENGTH BYTE

		END



;*****************************************************************************
;                 *** ZIPCHECK.ASM ******
; This proved to be the most valuable routine in our maillist package.
; This checks a Variable 'ST11', where ST is a state abbreviation and 
; 11 are the  first two digits of the zipcode.
; Valid combinations are taken from the list below.
; If ok, the variable remains unchanged.
; On error, the called variable contains 'ERR0'
; '0' reflects the following conditions:
; 1: No such state
; 2: Wrong zip for this state
;
; Foreign addresses must have 'ZZ' as state and are being left alone by
; this routine.
;*****************************************************************************


START	EQU 	0A470H 
ENDTAB  EQU     0EEH ; END OF TABLE
ENDSTA  EQU     0FFH ; END OF STATE


		ORG START


BEGIN:	INX 	H	; POINT TO FIRST BYTE

	LXI     B,ZIPTAB ; POINT TO START OF TABLE
	MOV	D,M	; LOAD STATE
	INX	H	; INTO D,E
	MOV	E,M	; H,L POINTS TO
	INX 	H	; ZIP
			; NOW

; CHECK FOR FOREIGN ZZ FIRST
	MVI	A,'Z' 
	CMP	D
	JNZ	LOOP1; NO MATCH 
	CMP	E
	RZ		;FOREIGN, GO HOME
; SCAN LIST FOR FIRST CHARACTER
LOOP1:	LDAX	B	; GET CHAR 
	CPI	ENDTAB	; END OF TABLE?
	JZ	ERROR1	; YUP, NO SUCH STATE 
	CMP	D	; COMPARE WITH 1ST IN VAR
	JZ	FOUND1	; MATCH..
      	INX	B	; INCREMENT POINTER
	JMP	LOOP1	; AND DO AGAIN


; IF FOUND, COMPARE NEXT CHAR
FOUND1:	INX	B	;POINT TO NEXT
	LDAX	B	;GET IT
	CMP	E	;COMPARE WITH 2ND 
	JNZ	LOOP1	;NO MATCH, SEARCH ON ...

;  MATCH, GO AND LOOK FOR ZIP.
; GET ZIP-WORD, CONVERT TO BYTE
	INX 	B	;BUMP TABLEPOINTER
	MOV	A,M	;GET ZIPCODE...
	ANI	00001111B	;MASK OFF MSBs
	RRC		; MOVE LOWER
	RRC		; 4 BITS
	RRC		; UP
	RRC
	MOV	D,A	;STORE
	INX	H	;INCREMENT POINTER
	MOV	A,M	;GET 2nd BYTE OF ZIP  
	ANI	00001111B	;MASK OFF MSBs
	ORA	D	;REBUILD
	MOV	E,A	;AND STORE

; SCAN CODE FOR BYTE
LOOP2:	LDAX	B	; GET CHAR 
	CPI	ENDSTA	; END OF STATE?
	JZ	ERROR2	; YUP, WRONG ZIP     
	CMP	E	; COMPARE WITH ZIP 
	RZ		; MATCH, GO HOME
      	INX	B	; INCREMENT POINTER
	JMP	LOOP2	; AND DO AGAIN

; ERRORHANDLERS


ERROR1:	INX	H	;BUMP POINTER
	MVI	M,'1'	;STORE 
	DCX	H	;ERRORCODE
	JMP	MAINE
ERROR2: MVI	M,'2'	;IN POS4
	DCX	H	;OF VAR
MAINE:  MVI	M,'R'   ;AND NOW ERR
	DCX	H
	MVI	M,'R'
	DCX	H
	MVI	M,'E'
	DCX	H
	RET		;GO HOME




NOSTA	EQU	'1'
WRZIP	EQU	'2'

; The following info is copied from the US Zipcode book.
; Small possessions and islands might not be on it .....

ZIPTAB:     	DW	 'AL' 
		DB 035H,036H,0FFH 
		DW    'AK' 
		DB 099H,0FFH 
		DW    'AZ' 
		DB 085H,086H,0FFH 
		DW    'AR' 
		DB 071H,072H,0FFH 
		DW    'CA' 
		DB 090H,091H,092H,093H,094H,095H,096H,0FFH 
		DW    'CO' 
		DB 080H,081H,0FFH 
		DW    'CT' 
		DB 006H,0FFH 
		DW    'DE' 
		DB 019H,0FFH 
		DW    'DC' 
		DB 020H,022H,0FFH 
		DW    'FL' 
		DB 032H,033H,034H,0FFH 
		DW    'GA' 
		DB 030H,031H,0FFH 
		DW    'HI' 
		DB 096H,0FFH 
		DW    'ID' 
		DB 083H,0FFH 
		DW    'IL' 
		DB 060H,061H,062H,0FFH 
		DW    'IN' 
		DB 046H,047H,0FFH 
		DW    'IA' 
		DB 050H,051H,052H,0FFH 
		DW    'KS' 
		DB 066H,067H,0FFH 
		DW    'KY' 
		DB 040H,041H,042H,0FFH 
		DW    'LA' 
		DB 070H,071H,0FFH 
		DW    'ME' 
		DB 003H,004H,0FFH 
		DW    'MD' 
		DB 020H,021H,0FFH 
		DW    'MA' 
		DB 001H,002H,0FFH 
		DW    'MI' 
		DB 048H,049H,0FFH 
		DW    'MN' 
		DB 055H,056H,0FFH 
		DW    'MS' 
		DB 038H,039H,0FFH 
		DW    'MO' 
		DB 063H,064H,065H,0FFH 
		DW    'MT' 
		DB 059H,0FFH 
		DW    'NE' 
		DB 068H,069H,0FFH 
		DW    'NV' 
		DB 089H,0FFH 
		DW    'NH' 
		DB 003H,0FFH 
		DW    'NJ' 
		DB 007H,008H,0FFH 
		DW    'NY' 
		DB 010H,011H,012H,013H,014H,009H,0FFH 
		DW    'NC' 
		DB 027H,028H,0FFH 
		DW    'ND' 
		DB 058H,0FFH 
		DW    'OH' 
		DB 043H,044H,045H,0FFH 
		DW    'OK' 
		DB 073H,074H,0FFH 
		DW    'OR' 
		DB 097H,0FFH 
		DW    'PA' 
		DB 015H,016H,017H,018H,019H,0FFH 
		DW    'PR' 
		DB 000H,007H,008H,0FFH 
		DW    'RI' 
		DB 002H,0FFH 
		DW    'SC' 
		DB 029H,0FFH 
		DW    'SD' 
		DB 057H,0FFH 
		DW    'TN' 
		DB 037H,038H,0FFH 
		DW    'TX' 
		DB 075H,076H,077H,078H,079H,0FFH 
		DW    'UT' 
		DB 084H,0FFH 
		DW    'VT' 
		DB 005H,0FFH 
		DW    'VA' 
		DB 022H,023H,024H,0FFH 
		DW    'WA' 
		DB 097H,098H,099H,0FFH 
		DW    'WV' 
		DB 024H,025H,026H,0FFH 
		DW    'WI' 
		DB 053H,054H,0FFH 
		DW    'WY' 
		DB 082H,083H,0FFH 
		DW    'VI' 
		DB 000H,0FFH 
		DW    'NM' 
		DB 087H,088H,0FFH 
		
		DB 0EEH; END OF TABLE
								
		end

;*****************************************************************************
;              *** Flushleft.asm *****
; THIS ROUTINE LEFT-JUSTIFIES A DBASE-STRING.
;*****************************************************************************

; SOME EQUATES

BLANK 	EQU	020H

	ORG 0A5d7H

; save parameters

start:	mov	b,m	;get length
	inx	h	;point to start
	shld	varpt	;save for later
	mvi	c,00h 	;init count
	mov	d,h	;init movepointer 
	mov	e,l		 
	call	spclp	;scan
	mov	a,c	;get count
	cpi	00h	;if zero...
	rz 		;..do nothing
	sta	spaces	;save spacount for later
	mov	d,h	;init movepointer
	mov	e,l
	lhld	varpt	;restore varpointer 
	mov	a,b	;get length
	sub	c	;subtract spaces
	mov	b,a	;b is now length of remaining string 
	mvi	c,00h	;zero c
; now move the string, c is counter

move:	LDAX	D 	;get first nonblank
	MOV	M,A 	;and store it
	inx	h	;update regs
	inx	d
	inr	c
	mov	a,c
	cmp	b	;whole string moved?
	jnz	move 	;nope, go on       
	mvi	b,00h	;yep, zero count
	NOP 
	NOP 
	lda	spaces  ;get spacecount
	mov	c,a	;and put into c
mvrst:	mvi	m,blank ;blank
	inr	b
	mov	a,b
	cmp	c	;done?
	rz		;yep
	INX	H	;BUMP POINTER
	JMP	MVRST	;NOPE


;scan var for leading spaces, if none, return
;c is count 

spclp:	mov a,c		;get count
	cmp b		;compare with length
	jnc	finivar	;reached end, all spaces
	mov	a,m	;get char
	cpi	blank	;space ?
	Rnz		;NOPE, GO HOME
	inr	c	;yep, update counter
	
	inx	h	;update varpointer 
	jmp	spclp	; and do again
	halt

finivar:	mvi c,00h	;zero count
	ret		;and return
fdchr:	inr	c	;counter update
	ret

spaces:	db	00h
varpt:	dw	0000h

end





;********* THIS CLEARS WINDOWS ON YOUR SCREEN FAST *********
; ENTER WITH A CALL TO A STRING WHICH CONTAINS
; It is presently installed for three windows called A, B, C
; the coordinates are below. 
;           ----------------------------
;           !        A         !   B   !
;           !                  !       !
;           ----------------------------
;           !                          !
;           !                          !
;           !              C           !
;           !                          !
;           !                          !
;           ----------------------------
;
; Enter the routine with any of the three characters in the
; called string. 
; "A" clears window A, "AB" clears windows A & B etc.
; THIS ROUTINE PRESENTLY EVALUATES ONLY THE FIRST THREE CHARS
; IN THE STRING.
; IF THERE'S A DIFFERENT CHAR THAN A,B,C THEN NOTHING
; HAPPENS

START EQU 0A628H ; SET THIS TO RIGHT START
BDOS	EQU 0005H

TRUE	EQU	0FFFFH
FALSE	EQU	NOT TRUE

TESTING EQU FALSE


IF TESTING
	ORG 0100H

LXI	H, 6500H
MVI	M, 02H
INX	H
MVI	M, 'B'
INX     H
MVI     M, ' '
LXI	H, 06500H
CALL	START - 01000H
RST	7
 	
	ORG START - 1000H
ENDIF

IF NOT TESTING
	ORG START
ENDIF
	MVI D,00H; RESET D
;EVALUATE COMMAND STRING FIRST, POINTER IS HL


EVAL:	MOV E,M		;LOAD LENGTH OF STRING
	INX H		;POINT TO FIRST
	SHLD	VARPT	;AND SAVE IT
	; D BECOMES COUNT
EVALLP:	MOV A,D 	; GET COUNT FOR CHARACTERS 
	CMP E		; STRING LENGTH EXHAUSTED ?	
	JNC  EEVAL	; YEP
	CPI 03H		; 3 EXHAUSTED?
	JNC  EEVAL	; YEP
	;NOW WORK ON THE CHAR 
	MOV A,M		;GET IT
	CPI 020H	;IS IT A SPACE (END OF COMMAND)?
	JZ	EEVAL	;YUP
	CPI 41H		;LESS THAN A?
	RC		;YEP, RETURN
	CPI 44H		;MORE THAN C?
	RNC		;YEP,RETURN
	; ITS VALID, UPDATE COUNTERS
	INR	D	;CHARCOUNT
	INX 	H	;AND POINTER
	JMP	EVALLP

EEVAL: 	MOV	A,D	;GET COUNT
	CMP	00H	;ZERO?
	RZ		;YEP, GO HOME
	
	LHLD	VARPT	;RESTORE VARPOINTER
	MOV 	A,D	;GET BOXCOUNT
	STA	BOXES	; AND SAVE
	MVI	A,00H	;CLEAR ...
	STA	MAINC	;..MAIN COUNTER

MAINLP: LDA	MAINC   ;GET COUNTER      
	LXI 	H,BOXES	;POINT TO BOXES
	CMP	M	;DONE ?
	RNC		;YEP, GO HOME
	LHLD	VARPT	;RESTORE HL
	;GET TYPE OF BOX
	MOV A,M		; HL IS VARPOINTER 
	INX	H	; INCREMENT
	SHLD	VARPT	; AND STORE FOR NEXT
	; TYPE IN ACCU, VARPT POINTS TO NEXT
	SUI	041H	;CHANGE CHAR TO NUMBER
			; A=0, B=1, C=2
	; NOW POINT TO THE RIGHT TABLE
	LXI	B,BOXA	; BC IS TABLEPOINTER
	MVI	E,00H	; CLEAR COUNT
INCLP:	CMP	E	; DONE? 
	JZ	DONE
	INX B! INX B! INX B! INX B! ;SKIP A FIELD 
	INR 	E	;UPDATE LOOP
	JMP	INCLP

	;WE ARE AT THE RIGHT TABLE NOW 
	;POSITION CURSOR
DONE:	LDAX	B	; GET X-CCORD
	ADI	20H	;ADD OFFSET
	STA	XPOS	;STORE IN COMMAND STRING
	INX	B	;BUMP POINTER
	LDAX	B	; GET Y-COORD
	ADI	1FH	; ADD OFFSET-1 (FOR INR)
	STA 	YPOS	;STORE IT
	INX 	B	; BUMP POINTER
	;LINE IS PREPARED FOR CURSORPOS
	MVI	A,00H
	STA	LOP1C	;RESET COUNTER
	LDAX	B	;GET COLS
	STA	COLS	;SAVE
	INX	B	;BUMP
	LDAX 	B	;GET ROWS
	STA	ROWS	;SAVE
;WE ARE AT THE START OF THE BOX NOW, LOCATIONS
; ARE INITIALIZED, NOW  CLEAR THE BOX

LOOP1:  LDA	LOP1C   ;GET COUNTER      
	LXI	H,ROWS 	;POINT TO ROWS 
	CMP	M	;DONE ?
	JNC	ENDMAIN	;YEP, GO HOME
	LXI	H,YPOS	;POINT TO COMMAND STRING
	INR	M	;INC YPOS IN STRING
	; COMMAND STRING INITIALIZED
	LXI	D,POSXY	;POINT TO COMMAND
	CALL	POSCURS	;POSITION CURSOR
	
; CURSOR POSITIONED
	MVI	A,00H
	STA 	LOP2C	;RESET COUNTER

LOOP2:	LDA	LOP2C   ;GET COUNTER      
	LXI	H,COLS 	;POINT TO COLUMS
	CMP	M	;DONE ?
	JNC	ENDLP1  ;YEP, DO NEXT LOOP
	MVI	E,020H	;LOAD SPACE
	CALL	CONOUT	;CONSOLE OUTPUT
	LXI	H,LOP2C	;POINT TO COUNTER
	INR	M	;INCREMENT IT
	JMP	LOOP2

ENDLP1:	LXI	H,LOP1C	;POINT TO COUNTER
	INR	M	;INCREMENT IT
	JMP	LOOP1	;AND DO AGAIN
ENDMAIN: LXI	H,MAINC	;POINT TO MAIN COUNTER
	INR 	M	;INCREMENT IT
	JMP	MAINLP	; AND GO HOME

SAVEREG: 	;SAVE ALL REGS
		XTHL
		PUSH D
		PUSH B
		PUSH PSW
		PCHL

RESTRC:		POP H
		POP PSW
		POP B
		POP D
		XTHL
		RET
POSCURS:	MVI A, 00H ; CLEAR
		STA UPFLAG ; FLAGS	
		STA LEFTFLAG
	        
; This is a kludge to overcome a problem with the typestring-function
; in CP/M: It uses '$' as a terminator and doesn't print it.
; The following isn't pretty, but it works ... 


		LDA YPOS ; TEST POSITION
		CPI 24H	;IS IT A $?
		JNZ NODOLY; NOPE
		DCR A	; Y-1
		STA YPOS
		MVI A, 0FFH ;YEP SET UPFLAG
		STA UPFLAG
NODOLY:		LDA XPOS  ; TEST XPOS
		CPI 24H; IS IT A$?
		JNZ OUTCURS    ; NOPE NORMAL OUTPUT
		DCR	A
		STA XPOS
		MVI A, 0FFH ; YEP, SET LEFTFLAG
		STA LEFTFLAG

OUTCURS:	CALL OUTSTR ; POSITION
		LDA UPFLAG
		CPI 0FFH	; SET?
		JNZ OUTC2	;NOPE
		MVI E,0AH	;LINEFEED
		CALL CONOUT
OUTC2:		LDA LEFTFLAG
		CPI 0FFH 	;SET
		RNZ		;NOPE, GO HOME
		MVI E, 0CH	;FORESPACE
		CALL CONOUT	;SEND IT
		RET		; AND GO HOME
OUTSTR: 	CALL SAVEREG   ; STRING ADDR IS IN DE
		MVI  C,09
	CALL BDOS
	CALL RESTRC
	RET

CONOUT:	CALL SAVEREG
	MVI	C,06H	;DIRECT CONSOLE IO
	CALL 	BDOS	;CHARACTERS HAS TO BE IN E
	CALL RESTRC
	RET

	

;STORAGE AND PARAMETERS 

VARPT:	DW 00H ; HL STORAGE
BOXES:  DB 00H ; HOW MANY ?
MAINC:	DB 00H ; COUNTER FOR MAIN LOOP
LOP1C:  DB 00H ; LOOP 1 COUNT
LOP2C:  DB 00H ; LOOP 2 COUNT
ROWS:	DB 00H ; TO BLANK 
COLS:	DB 00H ; TO BLANK
UPFLAG:	DB 00H
LEFTFLAG:	DB 00H

; Coordinates for the three windows

     ;    -X---Y---B--C-
BOXA:   DB 1 , 2 ,58, 3     
BOXB:   DB 60, 2 ,19, 3
BOXC:   DB 1 , 6 ,78, 17

; x/y positioning string on my tube, a SOROC 120
POSXY:	DB 1BH,'='
YPOS:   DB 00H; ADD 20H
XPOS:   DB 00H; ADD 20H
	DB '$'


	END



;
;*****************************************************************************
;*                Check keyboard for keypress. 				     *
;*							                     *
;* This routine checks the console and returns the ASCII-character           *
;* in the called  variable. If no key was pressed, 00Hex is returned.        *
;* This routine is useful to interrupt long printouts (for example).         *
;*****************************************************************************
;
bdos	equ 0005h
dicon	equ 06h   ; direct console input
getstat equ 0ffh  ; command for status

 
		org 43158; set this to your starting address

start:		mov a,m	;get length byte
		cpi 00h ;got to be at least 1
		rz      ; do nothing if empty string
		inx h	;bump varpointer
		push h	; and save it
		mvi c,dicon ;set up for direct console io
		mvi e,getstat ;and request status
		call bdos    ;do the function call
		pop  h	     ; restore varpointer
		ani  07fh    ; get rid of hi order bit
		mov  m,a     ; A holds 00 for no char,
		ret          ; or Ascii-code of char

		end
