implement pictured numeric output

README.md

@@ -10,10 +10,7 @@ System-specific functionality is obtained through a `sys` Forth word. This word
 
 ## Forth compatibility
 
-Alee implements a large majority of the "core" and "core extension" [word-sets](https://forth-standard.org/standard/core). Implementation is tracked in `compat.txt` with missing words listed below. Fundamental words are hard-coded into Alee while the rest of the implementation is found in `forth/core.fth` and `forth/core-ext.fth`. Running Alee without these implementation files will leave you with a very minimal word-set. These files may be compiled into the Alee binary by building the `standalone` target.
+Alee implements the entire "core" and majority of the "core extension" [word-sets](https://forth-standard.org/standard/core). Implementation is tracked in `compat.txt` with missing words listed below. Fundamental words are hard-coded into Alee while the rest of the implementation is found in `forth/core.fth` and `forth/core-ext.fth`. Running Alee without these implementation files will leave you with a very minimal word-set. These files may be compiled into the Alee binary by building the `standalone` target.
-
-**Missing** core features:  
-* Pictured numeric output conversion (e.g. `<# #>`)
 
 **Missing** core extensions:  
 ```

compat.txt

@@ -1,15 +1,15 @@
 6.1 Core words
 
 yes 6.1.0010 !
-    6.1.0030 #
+yes 6.1.0030 #
-    6.1.0040 #>
+yes 6.1.0040 #>
-    6.1.0050 #S
+yes 6.1.0050 #S
 yes 6.1.0070 '
 yes 6.1.0080 (
 yes 6.1.0090 *
 yes 6.1.0100 */
 yes 6.1.0110 */MOD
-yes 6.1.0120
+yes 6.1.0120 +
 yes 6.1.0130 +!
 yes 6.1.0140 +LOOP
 yes 6.1.0150 ,
@@ -33,7 +33,7 @@ yes 6.1.0430 2SWAP
 yes 6.1.0450 :
 yes 6.1.0460 ;
 yes 6.1.0480 <
-    6.1.0490 <#
+yes 6.1.0490 <#
 yes 6.1.0530 =
 yes 6.1.0540 >
 yes 6.1.0550 >BODY
@@ -81,7 +81,7 @@ yes 6.1.1540 FILL
 yes 6.1.1550 FIND
 yes 6.1.1561 FM/MOD
 yes 6.1.1650 HERE
-    6.1.1670 HOLD
+yes 6.1.1670 HOLD
 yes 6.1.1680 I
 yes 6.1.1700 IF
 yes 6.1.1710 IMMEDIATE (as "imm")
@@ -110,7 +110,7 @@ yes 6.1.2160 ROT
 yes 6.1.2162 RSHIFT
 yes 6.1.2165 S"
 yes 6.1.2170 S>D
-    6.1.2210 SIGN
+yes 6.1.2210 SIGN
 yes 6.1.2214 SM/REM
 yes 6.1.2216 SOURCE
 yes 6.1.2220 SPACE

forth/core.fth

@@ -217,3 +217,14 @@
            >r dup c@ swap >r base @ swap
            dup _isdigit - _uma
            r> char+ r> 1- repeat ;
+
+: <#       40 here c! ;
+: #>       2drop here dup c@ + 40 here c@ - ;
+: hold     -1 here +! here dup c@ + c! ;
+: #        base @
+           >r 0 i um/mod r> swap >r um/mod r>
+           rot 9 over <
+           if 7 + then 48 + hold ;
+: #s       begin # 2dup or 0= until ;
+: sign     0< if [char] - hold then ;
+

forth/test/core.fr

@@ -795,8 +795,9 @@ T{ GE7 -> 124 }T
 \ ------------------------------------------------------------------------
 ." TESTING SOURCE >IN WORD" CR
 
-\ : GS1 S" SOURCE" 2DUP EVALUATE
+\ String is compiled into GS1 and is distinct from SOURCE.
-\        >R SWAP >R = R> R> = ;
+\ : GS1 S" SOURCE" 2DUP 2DUP EVALUATE
+\       >R SWAP >R = R> R> = ;
 \ T{ GS1 -> <TRUE> <TRUE> }T
 
 VARIABLE SCANS
@@ -805,8 +806,8 @@ T{ 2 SCANS !
 345 RESCAN?
 -> 345 345 }T
 
-\ : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
+: GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
-\ T{ GS2 -> 123 123 123 123 123 }T
+T{ GS2 -> 123 123 123 123 123 }T
 
 : GS3 WORD COUNT SWAP C@ ;
 T{ BL GS3 HELLO -> 5 CHAR H }T
@@ -818,74 +819,73 @@ DROP -> 0 }T            \ BLANK LINE RETURN ZERO-LENGTH STRING
 T{ GS4 123 456
 -> }T
 
-\ \ ------------------------------------------------------------------------
+\ ------------------------------------------------------------------------
-\ TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
+." TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL" CR
-." TESTING BASE >NUMBER HEX DEMICAL" CR
+
-\ 
+: S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
-\ : S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
+   >R SWAP R@ = IF         \ MAKE SURE STRINGS HAVE SAME LENGTH
-\    >R SWAP R@ = IF         \ MAKE SURE STRINGS HAVE SAME LENGTH
+      R> ?DUP IF         \ IF NON-EMPTY STRINGS
-\       R> ?DUP IF         \ IF NON-EMPTY STRINGS
+    0 DO
-\     0 DO
+       OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
-\        OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
+       SWAP CHAR+ SWAP CHAR+
-\        SWAP CHAR+ SWAP CHAR+
+         LOOP
-\          LOOP
+      THEN
-\       THEN
+      2DROP <TRUE>         \ IF WE GET HERE, STRINGS MATCH
-\       2DROP <TRUE>         \ IF WE GET HERE, STRINGS MATCH
+   ELSE
-\    ELSE
+      R> DROP 2DROP <FALSE>      \ LENGTHS MISMATCH
-\       R> DROP 2DROP <FALSE>      \ LENGTHS MISMATCH
+   THEN ;
-\    THEN ;
+
-\ 
+: GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
-\ : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
+T{ GP1 -> <TRUE> }T
-\ T{ GP1 -> <TRUE> }T
+
-\ 
+: GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
-\ : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
+T{ GP2 -> <TRUE> }T
-\ T{ GP2 -> <TRUE> }T
+
-\ 
+: GP3  <# 1 0 # # #> S" 01" S= ;
-\ : GP3  <# 1 0 # # #> S" 01" S= ;
+T{ GP3 -> <TRUE> }T
-\ T{ GP3 -> <TRUE> }T
+
-\ 
+: GP4  <# 1 0 #S #> S" 1" S= ;
-\ : GP4  <# 1 0 #S #> S" 1" S= ;
+T{ GP4 -> <TRUE> }T
-\ T{ GP4 -> <TRUE> }T
 
 24 CONSTANT MAX-BASE         \ BASE 2 .. 36
 : COUNT-BITS
    0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
 COUNT-BITS 2* CONSTANT #BITS-UD      \ NUMBER OF BITS IN UD
 
-\ : GP5
+: GP5
-\    BASE @ <TRUE>
+   BASE @ <TRUE>
-\    MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
+   MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
-\       I BASE !            \ TBD: ASSUMES BASE WORKS
+      I BASE !            \ TBD: ASSUMES BASE WORKS
-\       I 0 <# #S #> S" 10" S= AND
+      I 0 <# #S #> S" 10" S= AND
-\    LOOP
+   LOOP
-\    SWAP BASE ! ;
+   SWAP BASE ! ;
-\ T{ GP5 -> <TRUE> }T
+T{ GP5 -> <TRUE> }T
-\ 
+
-\ : GP6
+: GP6
-\    BASE @ >R  2 BASE !
+   BASE @ >R  2 BASE !
-\    MAX-UINT MAX-UINT <# #S #>      \ MAXIMUM UD TO BINARY
+   MAX-UINT MAX-UINT <# #S #>      \ MAXIMUM UD TO BINARY
-\    R> BASE !            \ S: C-ADDR U
+   R> BASE !            \ S: C-ADDR U
-\    DUP #BITS-UD = SWAP
+   DUP #BITS-UD = SWAP
-\    0 DO               \ S: C-ADDR FLAG
+   0 DO               \ S: C-ADDR FLAG
-\       OVER C@ [CHAR] 1 = AND      \ ALL ONES
+      OVER C@ [CHAR] 1 = AND      \ ALL ONES
-\       >R CHAR+ R>
+      >R CHAR+ R>
-\    LOOP SWAP DROP ;
+   LOOP SWAP DROP ;
-\ T{ GP6 -> <TRUE> }T
+T{ GP6 -> <TRUE> }T
-\ 
+
-\ : GP7
+: GP7
-\    BASE @ >R    MAX-BASE BASE !
+   BASE @ >R    MAX-BASE BASE !
-\    <TRUE>
+   <TRUE>
-\    A 0 DO
+   A 0 DO
-\       I 0 <# #S #>
+      I 0 <# #S #>
-\       1 = SWAP C@ I 30 + = AND AND
+      1 = SWAP C@ I 30 + = AND AND
-\    LOOP
+   LOOP
-\    MAX-BASE A DO
+   MAX-BASE A DO
-\       I 0 <# #S #>
+      I 0 <# #S #>
-\       1 = SWAP C@ 41 I A - + = AND AND
+      1 = SWAP C@ 41 I A - + = AND AND
-\    LOOP
+   LOOP
-\    R> BASE ! ;
+   R> BASE ! ;
-\ 
+
-\ T{ GP7 -> <TRUE> }T
+T{ GP7 -> <TRUE> }T
 
 \ >NUMBER TESTS
 CREATE GN-BUF 0 C,
@@ -910,17 +910,17 @@ T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
 T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
 T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
 
-\ : GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
+: GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
-\    BASE @ >R BASE !
+   BASE @ >R BASE !
-\    <# #S #>
+   <# #S #>
-\    0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
+   0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
-\    R> BASE ! ;
+   R> BASE ! ;
-\ T{ 0 0 2 GN1 -> 0 0 0 }T
+T{ 0 0 2 GN1 -> 0 0 0 }T
-\ T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
+T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
-\ T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
+T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
-\ T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
+T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
-\ T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
+T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
-\ T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
+T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
 
 : GN2   \ ( -- 16 10 )
    BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;