09-28-2009, 01:19 PM
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]