From 3497073ce4fa8c523c05c4959b0c574c3c3bebcc Mon Sep 17 00:00:00 2001
From: Tim Vaughan <tgvaughan@gmail.com>
Date: Fri, 29 Apr 2016 00:28:15 +1200
Subject: [PATCH] Fixed 2swap bug, added ?do, fixed +loop.

Also, Mandelbrot Set example now works.
---
 examples/mandelbrot.4th | 40 +++++++++++++++++++----------
 src/forth.jl            | 11 +++++++-
 src/lib.4th             | 57 +++++++++++++++++++++++++++++------------
 3 files changed, 78 insertions(+), 30 deletions(-)

diff --git a/examples/mandelbrot.4th b/examples/mandelbrot.4th
index 5707acb..d31b028 100644
--- a/examples/mandelbrot.4th
+++ b/examples/mandelbrot.4th
@@ -32,19 +32,22 @@
 
 : csq 2dup c* ;
 
+
+: conj ( x y -- x -y )
+    negate
+;
+
 : cmagsq ( x1 y1 -- mag )
-    csq abs
+    2dup conj c* +
 ;
 
 ( --- Mandelbrot set calculations  --- )
 
 : iterate ( cr ci zr zi -- cr ci z'r z'i )
-    csq c+
+    2over 2swap csq c+
 ;
 
 : inSet? ( cr ci -- res )
-    DEBUGON
-
     0 0     ( z_0 = 0 )
     
     true    ( flag indicating set membership )
@@ -53,7 +56,7 @@
 
         iterate
         2dup cmagsq
-        4 >scaled > if
+        4 0 >scaled > if
             false ( not in set )
             leave
         then
@@ -66,19 +69,30 @@
 ;
 
 : xsteps 100 ;
-: ysteps 50 ;
+: ysteps 30 ;
 
 ( Draw the Mandelbrot Set!)
 : mandel ( x1 y1 x2 y2 -- )
 
-    1 pick 4 pick -
-    2 pick 5 pick do
-        i 0 inSet? if
-            42 emit
-        else
-            '.' emit
-        then
+    0 pick 3 pick - ysteps /
+    1 pick 4 pick do
+
+        2 pick 5 pick - xsteps /
+        3 pick 6 pick do
+
+            i j inSet? if
+                42 emit
+            else
+                space
+            then
+
+        dup +loop
+        drop
+
+        cr
+
     dup +loop
+    drop
 ;
 
 ( Clean up - hide non-standard multiplication def. )
diff --git a/src/forth.jl b/src/forth.jl
index fba2375..e7faf97 100644
--- a/src/forth.jl
+++ b/src/forth.jl
@@ -284,8 +284,17 @@ TWOSWAP = defPrimWord("2SWAP", () -> begin
     d = popPS()
     pushPS(b)
     pushPS(a)
-    pushPS(c)
     pushPS(d)
+    pushPS(c)
+    return NEXT
+end)
+
+TWOOVER = defPrimWord("2OVER", () -> begin
+    ensurePSDepth(4)
+    a = mem[reg.PSP-3]
+    b = mem[reg.PSP-2]
+    pushPS(a)
+    pushPS(b)
     return NEXT
 end)
 
diff --git a/src/lib.4th b/src/lib.4th
index ea4e7de..b9bfcca 100644
--- a/src/lib.4th
+++ b/src/lib.4th
@@ -109,6 +109,14 @@
 ;
 
 : DO IMMEDIATE
+        ' LIT , -1 , [COMPILE] IF
+        ' >R , ' >R ,
+        ' LIT , HERE @ 0 , ' >R ,
+        HERE @
+;
+
+: ?DO IMMEDIATE
+        ' 2DUP , ' - , [COMPILE] IF
         ' >R , ' >R ,
         ' LIT , HERE @ 0 , ' >R ,
         HERE @
@@ -132,12 +140,30 @@
 ;
 
 : +LOOP IMMEDIATE
+        ' DUP , \ Store copy of increment
+
         ' R> , ' SWAP , ' R> , ' SWAP , ' R> , ' SWAP , ' + , ' 2DUP , ' - ,
         ' SWAP , ' >R , ' SWAP , ' >R , ' SWAP , ' >R ,
-        ' 0<= , ' 0BRANCH ,
-        HERE @ - ,
+
+        \ Condition differently depending on sign of increment
+        ' SWAP , ' 0>= , [COMPILE] IF
+            ' 0<= ,
+        [COMPILE] ELSE
+            ' 0> ,
+        [COMPILE] THEN
+
+        \ Branch back to begining of loop kernel
+        ' 0BRANCH , HERE @ - ,
+
+        \ Clean up
         ' RDROP , ' RDROP , ' RDROP ,
+
+        \ Record address of loop end for any LEAVEs to use
         HERE @ SWAP !
+
+        [COMPILE] ELSE
+            ' 2DROP , \ Clean up if loop was entirely skipped (?DO)
+        [COMPILE] THEN
 ;
 
 : LOOP IMMEDIATE
@@ -171,12 +197,22 @@
         PSP@ SWAP -     ( add to the stack pointer )
         @               ( and fetch )
 ;
+: ROLL ( x_u x_u-1... x_0 u -- x_u-1 ... x_0 x_u )
+        1+ DUP PICK SWAP    ( x_u x_u-1 ... x_0 x_u u+1 )
+        PSP@ 1- SWAP - PSP@ 2- SWAP
+        DO
+            i 1+ @ i !
+        LOOP
+        SWAP DROP
+;
 
 ( With the looping constructs, we can now write SPACES, which writes n spaces to stdout. )
 : SPACES        ( n -- )
-        0 DO
-            SPACE
-        LOOP
+        DUP 0> IF
+            0 DO SPACE LOOP
+        ELSE
+            DROP
+        THEN
 ;
 
 ( Standard words for manipulating BASE. )
@@ -313,14 +349,3 @@
                 FALSE
         THEN
 ;
-
-: ROLL ( x_u x_u-1... x_0 u -- x_u-1 ... x_0 x_u )
-        1+ DUP PICK SWAP    ( x_u x_u-1 ... x_0 x_u u+1 )
-        PSP@ 1- SWAP - PSP@ 2- SWAP
-        DO
-            i 1+ @ i !
-        LOOP
-        SWAP DROP
-;
-
-include ../examples/mandelbrot.4th
-- 
2.20.1