The Museum of HP Calculators

HP Forum Archive 19

[ Return to Index | Top of Index ]

MCODE Keith Numbers
Message #1 Posted by PeterP on 28 Sept 2009, 1:19 p.m.

I know this is very late, but I cant stand not-finished projects…

A few weeks back Don posted a Keith Number Challenge. It was obvious that a RPN solution for the 41 would be way to slow but I thought a MCODE solution should be acceptable time-wise. Unfortunately I got side-tracked in this other thing called 'normal life' and so the rudimentary code was never finished. Well, this weekend I stole a couple of hours to finish it (an unfinished project is really nagging me...)

Below you find an MCODE function called NXTK (Next Keith number) that finds the next Keith number > than the value in X. Original X is stored into L.

I must say that I was surprised how long it takes to get to the Keith numbers past 10^3. Even in MCODE and m41 simulation it takes a few minutes to get from 7909 to 31331, which is one of the larger gaps.

One useful piece of code for MCODERS might be MFFR – MCODE Find Free Regs. Sometimes one needs some scratch area and this routine finds the first free available RAM register in the buffer area. It also checks if there are enough free regs ( you can request a certain number of free regs). To use it place the number of regs you need into B[S&X] and you get back in A[S&X] the absolute address off the first free reg which you then can use for your storage needs. If there are not enough free regs, the routine jumps out to [PACKE] (Packing, Try Again).

Pfhh, I'm happy this is finished now, I want to dig into 41Z from Angel!

Cheers

Peter

* KEITH.SRC
* Assembled by A41
* Mon Sep 28 13:11:18 2009
				.TITLE	""
				.JDA
				.EQU	[PCTOC]	00D7
;*****************************************************************************************
;*  FAT for Keith Number
;*****************************************************************************************
 0000 004			XROM	4	;XROM number. Same as RSU1
 0001 007			FCNS	7	;Header + functions
 0002 00001B			DEFR4K	[Header] 001B	;1 - first executable of header
 0004 000020			DEFR4K	[NXTK] 0020	;2 - Next Keith Number > than X
 0010 000			NOP
 0011 000			NOP
;-----------------------------------------------------------------------------------------
;-----------------------------------------------------------------------------------------
				.NAME	"PPL-KEITH"
*0012 088			#088		; "H"
*0013 014			#014		; "T"
*0014 009			#009		; "I"
*0015 005			#005		; "E"
*0016 00B			#00B		; "K"
*0017 02D			#02D		; "-"
*0018 00C			#00C		; "L"
*0019 010			#010		; "P"
*001A 010			#010		; "P"
 001B 3E0	[Header]	RTN
;-----------------------------------------------------------------------------------------
;-----------------------------------------------------------------------------
; FOCAl Function - NXTK - Next Keith Number
;            Max Range is 9 digits
; Dependencies : MLOCB (C, A[MS, S&X])
;                        MKBF
;                        Needs at least 10 free registers as temp storage
; Input:  X-Reg: Number to start for Keith search
; Output: X-Reg: Next Keith Number
; Errors: Paccking Try Again - Not enough space for temp storage
;             Data Error              - Start number is not valid
; Uses: A,B,C,M,N,Q + 9 tmp storage regs
; xxx sub
; ---------------------------------------------------------------------------
				.NAME	"NXTK"
*001C 08B			#08B		; "K"
*001D 014			#014		; "T"
*001E 018			#018		; "X"
*001F 00E			#00E		; "N"
 0020 1A0	[NXTK]		A=B=C=0		;master clear
 0021 130009			LDIS&X	009	;we need 9 registers
 0023 0E6			C<>B	S&X	;prep 9 into B [S&X]				
 0024 37903C0B8			?NCXQREL	[MFFR] 00B8	;find first reg of free space
 0027 066			A<>B	S&X	;put address of first reg into B
 0028 149024	[NonNormX]	?NCXQ	[ENCP00] 0952	;Need to shift number in x to right & kill exp
 002A 0F8			READ	3(x)
 002B 128			WRIT	4(L)	;store into L
 002C 2A0			SETDEC
 002D 0A0			SLCTP
 002E 31C			R=	1
 002F 2E2			?C#0	@R	;check we have no exponent larger than 9
 0030 0B50A3			?CGO	[ERRDE] 282D	;yes -> DATA ERROR
 0032 2F6			?C#0	XS	;no neg exponent either
 0033 0B50A3			?CGO	[ERRDE] 282D
 0035 39C			R=	0	;ok, focus on (single digit) exponent
 0036 2A2			C=-C-1	@R	;build complement, max single dig exp allowed. 
 0037 262			C=C-1	@R
 0038 3DA	[SRX]		RSHFC	M
 0039 262			C=C-1	@R
 003A 3F3			JNC	[SRX] -2 0038
 003B 046			C=0	S&X	;just clean up
 003C 0E8			WRIT	3(x)
 003D 13000A	[SplitNr]	LDIS&X	00A	;max of 9 digs, 10=DATA ERROR
 003F 0A6			A<>C	S&X
 0040 260			SETHEX
 0041 126			A=A+B	S&X	;MaxAddr
 0042 149024			?NCXQ	[ENCP00] 0952	;select Ramchip 0
 0044 0F8			READ	3(x)	;get Start Number
 0045 046			C=0	S&X
 0046 0A0			SLCTP
 0047 35C			R=	12
 0048 2E2			?C#0	@R	;do we have 10 digits?
 0049 0B50A3			?CGO	[ERRDE] 282D	; yes-> DATA ERROR
 004B 1A6	[FFD]		A=A-1	S&X	;address for 9 digits
 004C 2FC			RCR	13	;move next digit into C[12]
 004D 2E2			?C#0	@R	;Found first digit?
 004E 3EB			JNC	[FFD] -3 004B	;no -> try next (Find First Digit)
 004F 186			A=A-B	S&X	;yes->calc nr of digits
 0050 0A6106			C=A	S&X	;nr of digs into C[0]
 0052 066086			A=B	S&X	;Start Addr
 0054 0FA			C<>B	M	;store numeber into B[M], starts at C[12]
 0055 33C			RCR	1	;move Nr of Digs into C[MS]
 0056 0BE			A<>C	MS	;store into A[MS]
 0057 1BE			A=A-1	MS	;so that we can jump at 0
 0058 09E			B=A	MS	;save Nr of Digs into B[MS]
 0059 04E	[StoreD]	C=0	ALL	;Clean Slate
 005A 0C2			C=B	@R	;get first digit
 005B 27C			RCR	9	;move into C[3]
 005C 0A6106			C=A	S&X
 005E 270			RAMSLCT
 005F 2F0			WRITDATA
 0060 07A			A<>B	M	;move nr into A[M] to use LSFHTA
 0061 3FA			LSHFA	M	;move next digit to @R
 0062 07A			A<>B	M
 0063 166			A=A+1	S&X	;next address
 0064 1BE			A=A-1	MS	;underflow if past 1st digit
 0065 3A3			JNC	[StoreD] -12 0059
 0066 06E08E			A=B	ALL	;A[MS] = counter for Nr of dig, A[S&X] = start addr
 0068 01A			A=0	M	;Clean A
 0069 0A6106	[CalcS]		C=A	S&X	;A[S&X] is first(next) reg
 006B 270			RAMSLCT
 006C 038			READDATA
 006D 2A0			SETDEC
 006E 15A			A=A+C	M	;calc running sum
 006F 260			SETHEX
 0070 166			A=A+1	S&X
 0071 1BE			A=A-1	MS
 0072 3BB			JNC	[CalcS] -9 0069	;loop until all nrs are summed
 0073 1A6			A=A-1	S&X	;MaxAddr into A[S&X]
 0074 149024	[CheckNr]	?NCXQ	[ENCP00] 0952	;select Ramchip 0
 0076 0F8			READ	3(x)	;get number to check
 0077 2A0			SETDEC
 0078 25A			C=A-C	M	;calc delta 
 0079 2FA			?C#0	M	;identical?
 007A 103			JNC	[IsKeith] +32 009A
;------- Stepping stone
 007B 013			JNC	[cSS1] +2 007D
 007C 20B	[SS1]		JNC	[SplitNr] -63 003D
 007D 000	[cSS1]		NOP
;------- Stepping stone
 007E 0F8			READ	3(x)	;check if we are passed it already
 007F 31A			?A<C	M	;Sum <X
 0080 193			JNC	[NotKeith] +50 00B2	;no -> not keith
 0081 260	[ShiftRgs]	SETHEX
 0082 07E09E			A=B	MS	;nr of digits=regs
 0084 1BE			A=A-1	MS	;last digit needs special code
 0085 0C6			C=B	S&X	;data_reg(1)
 0086 226	[LShRgs]	C=C+1	S&X	;get next reg data
 0087 270			RAMSLCT		;read data_reg(2)
 0088 038			READDATA
 0089 266			C=C-1	S&X	;regs have their abs addr stored in S&X
 008A 270			RAMSLCT		;select data_reg(1)
 008B 2F0			WRITDATA		;write data_reg(2) into data_reg(1) 
 008C 226			C=C+1	S&X	;prep with data_reg(2) address
 008D 1BE			A=A-1	MS	;are we done yet?
 008E 3C3			JNC	[LShRgs] -8 0086	;not down yet
 008F 0BA11A			C=A	M	; now saev latest number
 0091 270			RAMSLCT		;last reg is already in C[S&X]
 0092 2F0			WRITDATA
 0093 04E			C=0	ALL	;prep for next run
 0094 00E			A=0	ALL
 0095 066086			A=B	S&X	;restore Start Addr
 0097 07E09E			A=B	MS	;restore counter as well
 0099 283			JNC	[CalcS] -48 0069	;calc new sum
 009A 149024	[IsKeith]	?NCXQ	[ENCP00] 0952	;need to normalize number in X-reg first...
 009C 0F8			READ	3(x)
 009D 35C			R=	12	;set pointer to first digit location
 009E 2FC	[LSC]		RCR	13	;= shift left once
 009F 2E2			?C#0	@R	;fonud first digit?
 00A0 3F3			JNC	[LSC] -2 009E	;keep on Left Shifting C
 00A1 0BA			C<>A	M	;now set exponent -> save M
 00A2 04E			C=0	ALL
 00A3 0DE			C=B	MS	;get exponent
 00A4 2FC			RCR	13	;move Nr of Digits into S&X
 00A5 0BA			C<>A	M	;get back mantissa
 00A6 0E8			WRIT	3(x)
 00A7 260			SETHEX
 00A8 06E			A<>B	ALL	;clear all buffer regs used
 00A9 0A6106	[ClRgs]		C=A	S&X	;
 00AB 270			RAMSLCT
 00AC 04E			C=0	ALL
 00AD 2F0			WRITDATA
 00AE 166			A=A+1	S&X	;next Reg
 00AF 1BE			A=A-1	MS
 00B0 3CB			JNC	[ClRgs] -7 00A9
 00B1 3E0			RTN
 00B2 0F8	[NotKeith]	READ	3(x)	;get number
 00B3 2A0			SETDEC
 00B4 23A			C=C+1	M	;increase test number by 1
 00B5 0E8			WRIT	3(x)	;save into X
 00B6 233			JNC	[SS1] -58 007C	;check if this one is Keith (via Stepping Stone)
 00B7 3E0			RTN
;-----------------------------------------------------------------------------
; ---------------------------------------------------------------------------
; Subroutine MFFR - MCODE Find Free Regs
; Input:   B[S&X = Nr of regs needed in hex
; Output:  A[S&X] has Address of first free reg
; Uses:    C[ALL], A[S&X], B[S&X]
; Error: Packing - try Again -> no free regs
; Assumes: nothing
; Leaves in hex mode
;---------------------------------------------------------------------------
 00B8 260	[MFFR]		SETHEX
 00B9 1300BF			LDIS&X	0BF	;Buffers start at 0C0
 00BB 106			A=C	S&X	;copy start address into A[S&X]
 00BC 166	[IncAdr]	A=A+1	S&X	;increment start address -> need to do smarter than +1, need to increment by buffer length!
 00BD 149024	[Cont1]		?NCXQ	[ENCP00] 0952	;select Ramchip 0
 00BF 378			READ	13(c)	;get .END. address
 00C0 306			?A<C	S&X	;if 0C0 >= .END. -> no free space
 00C1 09B			JNC	[MFFRE0] +19 00D4	;Packing, Try Again (error 0)
 00C2 0A6106			C=A	S&X	;copy next address to check into C [S&X]
 00C4 270			RAMSLCT
 00C5 038			READDATA
 00C6 2EE			?C#0	ALL	;if all 0, no more I/O data
 00C7 043			JNC	[Chk9reg] +8 00CF
 00C8 3A3			JNC	[IncAdr] -12 00BC
 00C9 23E			C=C+1	MS	;check if this is key assignment (buffer id F)
 00CA 397			JC	[IncAdr] -14 00BC	;yes-> check next reg
 00CB 0FC			RCR	10;
 00CC 056			C=0	XS
 00CD 146			A=A+C	S&X	;add to current reg
 00CE 37B			JNC	[Cont1] -17 00BD
 00CF 126	[Chk9reg]	A=A+B	S&X	;check if we have n regs. n in B[S&X] in hex
 00D0 149024			?NCXQ	[ENCP00] 0952	;select ramchip 0
 00D2 378			READ	13(c)	;read in .END.
 00D3 306			?A<C	S&X	;if >= .END. address -> not enough space
 00D4 009082	[MFFRE0]	?NCGO	[PACKE] 2002	;nope, not enough -> Packing, Try Again (error 0)
 00D6 186			A=A-B	S&X	;yes, bring first reg address into A[S&X]
 00D7 3E0			RTN		;yes -> A[S&X]


[ Return to Index | Top of Index ]

Go back to the main exhibit hall