Forth haiku

[tsh73]

Three lines of Forth makes some interesting color shifts.

Converted to BASIC manually ("pretend being Forth interpreter") (until pictures match that is)

Now I am tempted to make small forth-machine just for this ;)

'Forth haiku
'https://forthsalon.appspot.com
nomainwin

open "forth haiku" for graphics_nsb_nf as #gr
#gr "trapclose [quit]"
#gr "down"
#gr "size 2"

for x = 0 to 1 step 0.01
   xx=50+x*200
   for y = 0 to 1 step 0.01
       yy=50+(1-y)*200

       'Forth code:
       'x y + 1.23 +
       'x * y * y sin 2dup
       '* over < x -

       'x y is input, 0..1
       'line 1
       a1=x+y+1.23 '(.)
       'line 2
       a2=a1*x*y
       a21=sin(y)
       a23=a2
       a24=a21
       'line 3
       a3=a23*a24
       a31=a21
       a4=a3< a31
       '-remove a3, a31
       a41=a4-x
       '3 values on stack, so it is
       '  R G B A is
       'a2
       'a21
       'a41
       '1       (default)

       'looks it should be normalised
       if a2>1 then a2 = 1
       if a21>1 then a2 = 1
       if a41>1 then a2 = 1

       R=int(a2*255) mod 256
       G=int(a21*255) mod 256
       B=int(a41*255) mod 256

       'some tests
       'R=int(x*256)
       'G=int(y*256)
       'B=int((x+y)/2*256)

       'R=int(rnd(0)*256)
       'G=int(rnd(0)*256)
       'B=int(rnd(0)*256)

       #gr "color ";R;" ";G;" ";B
       #gr "set ";xx;" ";yy
   next
next
#gr "flush"
wait

[quit]
close #gr
end




[tsh73]

I did a Forth interpreter that does this program
It runs 7x slower when initial hardcoded program but gets same result
I tried more codes - added some new Forth statements (actually "t" and "/")
(now second code$ is active, comment it out to get first one)



Probably I could add more operators - it is fun
forthsalon.appspot.com/word-list

But the power of Forth is in creating new words from existing ones
like
: q dup * ;
means "define new code named "q" that does "dup *" "
(and then that word could me used for anything, making new words too!)
And I have no idea how to do *that*
Probably long CASE is not the answer...
'Forth haiku
'https://forthsalon.appspot.com

'v 02 - try to add forth interpreter
'v 03 - try to use it
'v 04 - try more codes
nomainwin

global stack$

'Fort code:
code$ = _
"x y + 1.23 + "+_
"x * y * y sin 2dup "+_
"* over < x - "

'this one uses t (time) so subsequent runs differ
code$ = _
"x y t sin 1 + 2 / "

'for t (time) variable:
'snce BASIC is slow, get t value once on start then use the same
t0$=str$(time$("ms")/1000)

pi=acs(-1)

open "forth haiku" for graphics_nsb_nf as #gr
#gr "trapclose [quit]"
#gr "down"
#gr "size 2"

t0=time$("ms")

for x = 0 to 1 step 0.01
   xx=50+x*200
   for y = 0 to 1 step 0.01
       yy=50+(1-y)*200
       SCAN

       gosub [interpret]
       'supposed to leave on stack
       ' R G B A
       'missing supposed to be filled with 0 0 0 1

       if word$(stack$, 4) <> "" then
       '4
           a=val(pop$())
           b=val(pop$())
           g=val(pop$())
           r=val(pop$())
       else
           a=1    '(default)    ignored anyway
           b=val(pop$())
           g=val(pop$())
           r=val(pop$())
       end if

       'looks it should be normalized
       if a>1 then a = 1
       if b>1 then b = 1
       if g>1 then g = 1
       if r>1 then r = 1

       R=int(r*255)
       G=int(g*255)
       B=int(b*255)

       'some tests
       'R=int(x*256)
       'G=int(y*256)
       'B=int((x+y)/2*256)

       'R=int(rnd(0)*256)
       'G=int(rnd(0)*256)
       'B=int(rnd(0)*256)

       #gr "color ";R;" ";G;" ";B
       #gr "set ";xx;" ";yy
   next
next
#gr "flush"
'notice time$("ms")-t0

wait

[quit]
close #gr
end

sub push s$
   stack$=s$+" "+stack$    'stack
end sub

function pop$()
   'it does return empty on empty stack
   pop$=word$(stack$,1)
   stack$=mid$(stack$,instr(stack$," ")+1)
end function

[interpret]
   stack$=""
   w$=""
   i=0
   while 1
       i=i+1
       w$=word$(code$, i)
       if w$="" then exit while
       'print i, w$
       'call push w$
       select case w$
           case "x"
               call push str$(x)
           case "y"
               call push str$(y)
           case "t"
               'real ticking time its changing (and BASIC is slow)
               'call push str$(time$("ms")/1000)
               'so use starting value instead
               call push t0$
           case "+"
               call push str$(val(pop$())+val(pop$()))
           case "*"
               call push str$(val(pop$())*val(pop$()))
           case "-"
               op2=val(pop$())
               call push str$(val(pop$())-op2)
           case "/"
               op2=val(pop$())
               call push str$(val(pop$())/op2)
           case "<"
               op2=val(pop$())
               call push str$(val(pop$())<op2)
           case "sin"
               call push str$(sin(val(pop$())))
           case "2dup"
               op1$=pop$()
               op2$=pop$()
               call push op2$
               call push op1$
               call push op2$
               call push op1$
           case "over"
               op1$=pop$()
               op2$=pop$()
               call push op2$
               call push op1$
               call push op2$
           case else
               'is it a number?
               call push w$
       end select
   wend
return


[tsh73]

New picture, new code added/ Depends on t so different on next run



'Forth haiku
'https://forthsalon.appspot.com

'v 02 - try to add forth interpreter
'v 03 - try to use it
'v 04 - try more codes (t /)
'v 05 - still more codes, (dup, lower normalization)
nomainwin

global stack$

'Fort code:
code$ = _
"x y + 1.23 + "+_
"x * y * y sin 2dup "+_
"* over < x - "

'this one uses t (time) so subsequent runs differ
code$ = _
"x y t sin 1 + 2 / "

code$ = _
"x 9.4 * sin "+_
"y 9.4 * sin "+_
"t 4 * sin "+_
"* * "+_
"dup t 2 * sin * "+_
"dup t 3 * sin * "

'for t (time) variable:
'snce BASIC is slow, get t value once on start then use the same
t0$=str$(time$("ms")/1000)

pi=acs(-1)

open "forth haiku" for graphics_nsb_nf as #gr
#gr "trapclose [quit]"
#gr "down"
#gr "size 2"

t0=time$("ms")

for x = 0 to 1 step 0.01
   xx=50+x*200
   for y = 0 to 1 step 0.01
       yy=50+(1-y)*200
       SCAN

       gosub [interpret]
'print x, y, stack$
'wait
       'supposed to leave on stack
       ' R G B A
       'missing supposed to be filled with 0 0 0 1

       if word$(stack$, 4) <> "" then
       '4
           a=val(pop$())
           b=val(pop$())
           g=val(pop$())
           r=val(pop$())
       else
           a=1    '(default)    ignored anyway
           b=val(pop$())
           g=val(pop$())
           r=val(pop$())
       end if

       'looks it should be normalized
       if a>1 then a = 1
       if b>1 then b = 1
       if g>1 then g = 1
       if r>1 then r = 1
       if a<0 then a = 0
       if b<0 then b = 0
       if g<0 then g = 0
       if r<0 then r = 0

       R=int(r*255)
       G=int(g*255)
       B=int(b*255)

       'some tests
       'R=int(x*256)
       'G=int(y*256)
       'B=int((x+y)/2*256)

       'R=int(rnd(0)*256)
       'G=int(rnd(0)*256)
       'B=int(rnd(0)*256)

       #gr "color ";R;" ";G;" ";B
       #gr "set ";xx;" ";yy
   next
next
#gr "flush"
'notice time$("ms")-t0

wait

[quit]
close #gr
end

sub push s$
   stack$=s$+" "+stack$    'stack
end sub

function pop$()
   'it does return empty on empty stack
   pop$=word$(stack$,1)
   stack$=mid$(stack$,instr(stack$," ")+1)
end function

[interpret]
   stack$=""
   w$=""
   i=0
   while 1
       i=i+1
       w$=word$(code$, i)
       if w$="" then exit while
       'print i, w$
       'call push w$
       select case w$
           case "x"
               call push str$(x)
           case "y"
               call push str$(y)
           case "t"
               'real ticking time its changing (and BASIC is slow)
               'call push str$(time$("ms")/1000)
               'so use starting value instead
               call push t0$
           case "+"
               call push str$(val(pop$())+val(pop$()))
           case "*"
               call push str$(val(pop$())*val(pop$()))
           case "-"
               op2=val(pop$())
               call push str$(val(pop$())-op2)
           case "/"
               op2=val(pop$())
               call push str$(val(pop$())/op2)
           case "<"
               op2=val(pop$())
               call push str$(val(pop$())<op2)
           case "sin"
               call push str$(sin(val(pop$())))
           case "dup"
               op1$=pop$()
               call push op1$
               call push op1$
           case "2dup"
               op1$=pop$()
               op2$=pop$()
               call push op2$
               call push op1$
               call push op2$
               call push op1$
           case "over"
               op1$=pop$()
               op2$=pop$()
               call push op2$
               call push op1$
               call push op2$
           case else
               'is it a number?
               call push w$
       end select
   wend
return


[plus]

Is this like Basic's Draw command? Where you write drawing code steps in a little interpreter?

I've done that but I don't know if I have a an option to save a routine under a name, that would be a power alright!
But I can save a routine in a String Variable.

[tsh73]

Not quite
This is a site
forthsalon.appspot.com/
that calls program for each point
Input are x and y (and t in seconds if you wish)
(coords are floats 0..1)
and program supposed to return color of that point (RGBA values, 0..1)

But it happened that program is in Forth language (variant)
On site them likely compile that to WebGL (not that I know what it is)
and it works really really fast

I am just reading on Forth, this caught my attention
And it happens that some limited interpreter is pretty easy to make

[tenochtitlanuk]

I really liked Forth years ago- extensible and very fast. First ran on an 8K PET in the Seventies. Even ran a Jupiter Ace whose language was Forth. Still got my copies of Charles Moore's original book, and Loeliger's, and may still own an ACE with an external keyboard added. I doubt it would still run, and needed a TV and tape recorder to work. But it is a 'write mainly. Read seldom' language, which makes sense to the author as they build up the words and then the program, bottom up. It is MUCH harder to work out the code written by someone else- or even by yourself the previous day!

This looks fun- but I've a lot on my plate at the moment.

Don't want to promote another BASIC, but you can run Forth from within RR's BBC BASIC.

[tsh73]

Feb 19, 2023 10:54:13 GMT tsh73 said:

I did a Forth interpreter that does this
But the power of Forth is in creating new words from existing ones
like
: q dup * ;
means "define new code named "q" that does "dup *" "
(and then that word could me used for anything, making new words too!)
And I have no idea how to do *that*
Probably long CASE is not the answer...

Well, after sleeping it over, I got that idea what simple macro expansion should work
And it seems it does work
(here
": iii x y z* sin ;"
is definition of a new word)

---

EDIT I did some reading and "simple macro expansion works" is a general trait of Concatenative languages,
en.wikipedia.org/wiki/Concatenative_programming_language
Forth being one of examples.

---

'Forth haiku
'https://forthsalon.appspot.com

'v 02 - try to add forth interpreter
'v 03 - try to use it
'v 04 - try more codes (t /)
'v 05 - still more codes, (dup, lower normalization)
'nomainwin

global stack$

'Fort code:
code$ = _
"x y + 1.23 + "+_
"x * y * y sin 2dup "+_
"* over < x - "

'this one uses t (time) so subsequent runs differ
code$ = _
"x y t sin 1 + 2 / "

code$ = _
"x 9.4 * sin "+_
"y 9.4 * sin "+_
"t 4 * sin "+_
"* * "+_
"dup t 2 * sin * "+_
"dup t 3 * sin * "

'''Candy 69 bytes - Manwe + Digimind
'div by zero
code$ = _
": r dup y 12 ** * t + sin swap x * cos + 1 mod ; "+_
"18 r "+_
"25 r "+_
"dup 12 r / "

'''light drop - BradN
code$ = _
": iii x y z* "+_
"sin ; x 5 * x y "+_
"- iii exp y iii "

'for t (time) variable:
'snce BASIC is slow, get t value once on start then use the same
t0$=str$(time$("ms")/1000)

pi=acs(-1)

open "forth haiku" for graphics_nsb_nf as #gr
#gr "trapclose [quit]"
#gr "down"
#gr "size 2"

print "code$"
print code$
print
gosub [expandMacros]
print "expanded"
print code$
'wait

t0=time$("ms")

for x = 0 to 1 step 0.01
   xx=50+x*200
   for y = 0 to 1 step 0.01
       yy=50+(1-y)*200
       SCAN

       gosub [interpret]
       'print x, y, stack$
       'wait
       'supposed to leave on stack
       ' R G B A
       'missing supposed to be filled with 0 0 0 1

       if word$(stack$, 4) <> "" then
       '4
           a=val(pop$())
           b=val(pop$())
           g=val(pop$())
           r=val(pop$())
       else
           a=1    '(default)    ignored anyway
           b=val(pop$())
           g=val(pop$())
           r=val(pop$())
       end if

       'looks it should be normalized
       if a>1 then a = 1
       if b>1 then b = 1
       if g>1 then g = 1
       if r>1 then r = 1
       if a<0 then a = 0
       if b<0 then b = 0
       if g<0 then g = 0
       if r<0 then r = 0

       R=int(r*255)
       G=int(g*255)
       B=int(b*255)

       'some tests
       'R=int(x*256)
       'G=int(y*256)
       'B=int((x+y)/2*256)

       'R=int(rnd(0)*256)
       'G=int(rnd(0)*256)
       'B=int(rnd(0)*256)

       #gr "color ";R;" ";G;" ";B
       #gr "set ";xx;" ";yy
   next
next
#gr "flush"
'notice time$("ms")-t0

wait

[quit]
close #gr
end

sub push s$
   stack$=s$+" "+stack$    'stack
end sub

function pop$()
   'it does return empty on empty stack
   pop$=word$(stack$,1)
   stack$=mid$(stack$,instr(stack$," ")+1)
end function

[interpret]
   stack$=""
   w$=""
   i=0
   while 1
       i=i+1
       w$=word$(code$, i)
       if w$="" then exit while
       'print i, w$
       'call push w$
       select case w$
           case "x"
               call push str$(x)
           case "y"
               call push str$(y)
           case "t"
               'real ticking time its changing (and BASIC is slow)
               'call push str$(time$("ms")/1000)
               'so use starting value instead
               call push t0$
           case "+"
               call push str$(val(pop$())+val(pop$()))
           case "*"
               call push str$(val(pop$())*val(pop$()))
           case "**"
               op2=val(pop$())
               call push str$(val(pop$())^op2)
           case "-"
               op2=val(pop$())
               call push str$(val(pop$())-op2)
           case "/"
               op2=val(pop$())
               call push str$(val(pop$())/op2)
           case "mod"
               op2=val(pop$())
               call push str$(val(pop$()) mod op2)
           case "<"
               op2=val(pop$())
               call push str$(val(pop$())<op2)
           case "sin"
               call push str$(sin(val(pop$())))
           case "exp"
               call push str$(exp(val(pop$())))
           case "swap"
               op1$=pop$()
               op2$=pop$()
               call push op1$
               call push op2$
           case "dup"
               op1$=pop$()
               call push op1$
               call push op1$
           case "2dup"
               op1$=pop$()
               op2$=pop$()
               call push op2$
               call push op1$
               call push op2$
               call push op1$
           case "over"
               op1$=pop$()
               op2$=pop$()
               call push op2$
               call push op1$
               call push op2$
           case "z*" ' Complex multiplication.
               'with the real part deeper in the stack (corresponding to real part first when pushing constants onto the stack.
               '( a b c d -- a*c-b*d a*d+b*c )
               opD=val(pop$())
               opC=val(pop$())
               opB=val(pop$())
               opA=val(pop$())
               call push str$(opA*opC-opB*opD)
               call push str$(opA*opD+opB*opC)
           case else
               'is it a number?
               call push w$
       end select
   wend
return

[expandMacros]
p=instr(code$,":")
while p
   SCAN
   pre$=mid$(code$,1,p-1)
   pp=instr(code$,";",p)
   def$=trim$(mid$(code$,p+1,pp-p-1))
       old$=word$(def$,1)
       new$=trim$(mid$(def$, instr(def$, " ")+1))
   rest$=mid$(code$,pp+1)
   print ,pre$
   print ,def$
   print ,old$,new$
   print ,rest$

   rest$=replstr$(rest$, " "+old$+" ", " "+new$+" ")
   print ">>", rest$
   code$=trim$(pre$)+" "+trim$(rest$)

   'p=instr(code$,":",p+1)
   p=instr(code$,":")  'from  start
wend
return

'-------------------------------------
'from lb45func.bas
function replstr$(source$, old$, new$)
do
 i = instr(source$, old$, i+1)
 if i then
   source$ = left$(source$,i-1);new$;mid$(source$,i+len(old$))
   i = i + len(new$) - 1
 end if
loop until i = 0
replstr$ = source$
end function


[tsh73]

Another one. I would see error earlier but I had some error checking (undefined word 'cos') on other computer ;(
(inserted this check)

'Forth haiku
'https://forthsalon.appspot.com

'v 02 - try to add forth interpreter
'v 03 - try to use it
'v 04 - try more codes (t /)
'v 05 - still more codes, (dup, lower normalization)
'nomainwin

global stack$

'Fort code:
code$ = _
"x y + 1.23 + "+_
"x * y * y sin 2dup "+_
"* over < x - "

'this one uses t (time) so subsequent runs differ
code$ = _
"x y t sin 1 + 2 / "

code$ = _
"x 9.4 * sin "+_
"y 9.4 * sin "+_
"t 4 * sin "+_
"* * "+_
"dup t 2 * sin * "+_
"dup t 3 * sin * "

'''Candy 69 bytes - Manwe + Digimind
'div by zero
code$ = _
": r dup y 12 ** * t + sin swap x * cos + 1 mod ; "+_
"18 r "+_
"25 r "+_
"dup 12 r / "

'''light drop - BradN
'code$ = _
'": iii x y z* "+_
'"sin ; x 5 * x y "+_
'"- iii exp y iii "

'for t (time) variable:
'snce BASIC is slow, get t value once on start then use the same
t0$=str$(time$("ms")/1000)

pi=acs(-1)

open "forth haiku" for graphics_nsb_nf as #gr
#gr "trapclose [quit]"
#gr "down"
#gr "size 2"

print "code$"
print code$
print
gosub [expandMacros]
print "expanded"
print code$
'wait

t0=time$("ms")

for x = 0 to 1 step 0.01
   xx=50+x*200
   for y = 0 to 1 step 0.01
       yy=50+(1-y)*200
       SCAN

       gosub [interpret]
       'print "stack$"
       'print stack$
       'wait
       'print x, y, stack$
       'wait
       'supposed to leave on stack
       ' R G B A
       'missing supposed to be filled with 0 0 0 1

       if word$(stack$, 4) <> "" then
       '4
           a=val(pop$())
           b=val(pop$())
           g=val(pop$())
           r=val(pop$())
       else
           a=1    '(default)    ignored anyway
           b=val(pop$())
           g=val(pop$())
           r=val(pop$())
       end if

       'looks it should be normalized
       if a>1 then a = 1
       if b>1 then b = 1
       if g>1 then g = 1
       if r>1 then r = 1
       if a<0 then a = 0
       if b<0 then b = 0
       if g<0 then g = 0
       if r<0 then r = 0

       R=int(r*255)
       G=int(g*255)
       B=int(b*255)

       'some tests
       'R=int(x*256)
       'G=int(y*256)
       'B=int((x+y)/2*256)

       'R=int(rnd(0)*256)
       'G=int(rnd(0)*256)
       'B=int(rnd(0)*256)

       #gr "color ";R;" ";G;" ";B
       #gr "set ";xx;" ";yy
   next
next
#gr "flush"
'notice time$("ms")-t0

wait

[quit]
close #gr
end

sub push s$
   stack$=s$+" "+stack$    'stack
end sub

function pop$()
   'it does return empty on empty stack
   pop$=word$(stack$,1)
   stack$=mid$(stack$,instr(stack$," ")+1)
end function

[interpret]
   'print"=================="
   stack$=""
   w$=""
   i=0
   while 1
       i=i+1
       w$=word$(code$, i)
       'print w$;" ";
       if w$="" then exit while
       'print i, w$
       'call push w$
       select case w$
           case "x"
               call push str$(x)
           case "y"
               call push str$(y)
           case "t"
               'real ticking time its changing (and BASIC is slow)
               'call push str$(time$("ms")/1000)
               'so use starting value instead
               call push t0$
           case "+"
               call push str$(val(pop$())+val(pop$()))
           case "*"
               call push str$(val(pop$())*val(pop$()))
           case "**"
               op2=val(pop$())
               call push str$(val(pop$())^op2)
           case "-"
               op2=val(pop$())
               call push str$(val(pop$())-op2)
           case "/"
               op2=val(pop$())
               'if op2<>0 then
                   call push str$(val(pop$())/op2)
               'else
               '    call push "0"
               'end if
           case "mod"
               op2=val(pop$())
               op1=val(pop$())
               call push str$(op1 mod op2 +(op1<0)*op2)    'Forth MOD is different
           case "<"
               op2=val(pop$())
               call push str$(val(pop$())<op2)
           case "sin"
               call push str$(sin(val(pop$())))
           case "cos"
               call push str$(cos(val(pop$())))
           case "exp"
               call push str$(exp(val(pop$())))
           case "swap"
               op1$=pop$()
               op2$=pop$()
               call push op1$
               call push op2$
           case "dup"
               op1$=pop$()
               call push op1$
               call push op1$
           case "2dup"
               op1$=pop$()
               op2$=pop$()
               call push op2$
               call push op1$
               call push op2$
               call push op1$
           case "over"
               op1$=pop$()
               op2$=pop$()
               call push op2$
               call push op1$
               call push op2$
           case "z*" ' Complex multiplication.
               'with the real part deeper in the stack (corresponding to real part first when pushing constants onto the stack.
               '( a b c d -- a*c-b*d a*d+b*c )
               opD=val(pop$())
               opC=val(pop$())
               opB=val(pop$())
               opA=val(pop$())
               call push str$(opA*opC-opB*opD)
               call push str$(opA*opD+opB*opC)
           case else
               'is it a number?
               if val(w$)=0 and w$<>"0" and w$<>"0.0" then
                   notice "Error!"+chr$(13)+"Undefined (yet) word"+chr$(13)+w$
                   goto [quit]
               else
                   call push w$
               end if
       end select
       'print stack$
   wend
   'print"=================="
return

[expandMacros]
p=instr(code$,":")
while p
   SCAN
   pre$=mid$(code$,1,p-1)
   pp=instr(code$,";",p)
   def$=trim$(mid$(code$,p+1,pp-p-1))
       old$=word$(def$,1)
       new$=trim$(mid$(def$, instr(def$, " ")+1))
   rest$=mid$(code$,pp+1)
   'print ,pre$
   print "Found new word: ";old$
   print , new$
   'print ,old$,new$
   'print ,rest$

   rest$=replstr$(rest$, " "+old$+" ", " "+new$+" ")
   'print ">>", rest$
   code$=trim$(pre$)+" "+trim$(rest$)

   'p=instr(code$,":",p+1)
   p=instr(code$,":")  'from  start
wend
return

'-------------------------------------
'from lb45func.bas
function replstr$(source$, old$, new$)
do
 i = instr(source$, old$, i+1)
 if i then
   source$ = left$(source$,i-1);new$;mid$(source$,i+len(old$))
   i = i + len(new$) - 1
 end if
loop until i = 0
replstr$ = source$
end function