From edab2d382fb0849e559bfb9e59d10593209b80e5 Mon Sep 17 00:00:00 2001
From: Brad Nelson <flagxor@gmail.com>
Date: Thu, 14 Nov 2024 08:13:28 -0800
Subject: [PATCH] Adding WIP w/ gemini example.

---
 examples/gemini/arrays.fs | 131 ++++++++++++++++++++++++++++++++
 examples/gemini/gemini.fs |  63 ++++++++++++++++
 examples/gemini/json.fs   | 154 ++++++++++++++++++++++++++++++++++++++
 examples/gemini/slurp.fs  |   8 ++
 4 files changed, 356 insertions(+)
 create mode 100755 examples/gemini/arrays.fs
 create mode 100755 examples/gemini/gemini.fs
 create mode 100755 examples/gemini/json.fs
 create mode 100644 examples/gemini/slurp.fs

diff --git a/examples/gemini/arrays.fs b/examples/gemini/arrays.fs
new file mode 100755
index 0000000..14e7ca7
--- /dev/null
+++ b/examples/gemini/arrays.fs
@@ -0,0 +1,131 @@
+#! /usr/bin/env ueforth
+
+vocabulary arrays also internals also arrays definitions
+
+128 constant stack-depth
+
+( Stack for arrays )
+create astack    stack-depth cells allot
+variable ap    astack ap !
+: apush ( a -- ) cell ap +! ap @ ! ;
+: apop ( -- a ) ap @ @  cell negate ap +! ;
+: top ( -- a ) ap @ @ ;
+: under ( -- a ) ap @ cell - @ ;
+
+( Secondary stack for arrays )
+create arstack   stack-depth cells allot
+variable arp   arstack arp !
+: >a   apop   cell arp +! arp @ ! ;
+: a>   arp @ @  cell negate arp +! apush ;
+
+( Array types )
+0 constant MIXED
+1 constant STRING
+2 constant INTEGER
+3 constant REAL
+create array-sizes   cell , 1 , cell , 4 ,
+: >esize ( type -- n ) cells array-sizes + @ ;
+
+\ ref n ^type data...
+3 cells constant header-size
+: >type ( a -- a ) -1 cells + ;
+: >count ( a -- a ) -2 cells + ;
+: >ref ( a -- a ) -3 cells + ;
+
+( Size of array data in bytes )
+: bytes ( a -- n ) dup >type @ >esize swap >count @ * ;
+
+( Create an uninitialized array )
+: array ( n type -- a )
+   2dup >esize * header-size + allocate throw header-size + apush
+   top >type !   top >count !   0 top >ref ! ;
+
+( Reference counting for arrays )
+: ref ( a -- ) 1 over >ref +! ;
+: unref ( a -- )
+   dup 0= if drop exit then
+   -1 over >ref +!
+   dup >ref @ 0< if
+     dup >type @ MIXED = if
+       dup dup >count @ 0 ?do
+         dup @ recurse cell+
+       loop
+       drop 
+     then
+     header-size - free throw exit
+   then drop ;
+
+( Stack manipulation )
+: adrop ( a: a -- ) apop unref ;
+: anip ( a: a b -- b ) apop apop unref apush ;
+: adup ( a: a -- a a ) top ref apush ;
+: aswap ( a: a b -- b a ) apop apop swap apush apush ;
+
+( Index into the top of the stack )
+: a@ ( n a: a -- a: a ) cells top + @ ref adrop apush ;
+
+( Raw array creation words )
+: empty ( -- a: a ) 0 MIXED array ;
+: box ( a: a -- a ) apop 1 MIXED array top ! ;
+: _s ( a n -- a: a ) dup STRING array top swap cmove ;
+: _c ( ch -- a: a ) 1 STRING array top c! ;
+: _i ( n -- a: a ) 1 INTEGER array top ! ;
+: _f ( f: n -- a: a ) 1 REAL array top sf! ;
+: _s"   postpone s" state @ if postpone _s else _s then ; immediate
+
+: aconstant   create apop , does> @ ref apush ;
+
+( Convert integer array to floats )
+: n>f
+   top >count @ REAL array
+   under top top >count @ 0 ?do over @ s>f dup sf! sfloat+ >r cell+ r> loop 2drop anip ;
+
+( Force integers to real. )
+: binuminal
+   top >type @ INTEGER = under >type @ REAL = and if n>f then
+   under >type @ INTEGER = top >type @ REAL = and if apop n>f apush then
+;
+
+0 value layer
+: lst ( a -- )
+   layer spaces
+   dup >type @ case
+     MIXED of
+       ." [" cr
+       2 +to layer
+       dup >count @ 0 ?do
+         dup @ recurse cell+ cr
+       loop
+       drop
+       -2 +to layer
+       layer spaces ." ]"
+     endof
+     STRING of dup >count @ type endof
+     INTEGER of dup >count @ 0 ?do dup @ . cell+ loop drop endof
+     REAL of dup >count @ 0 ?do dup sf@ f. sfloat+ loop drop endof
+   endcase
+;
+: a. ( a -- ) top lst adrop ;
+
+: catenate ( a: a a -- a ) ( catenate )
+  binuminal
+  top >type @ under >type @ = if
+    under >count @ top >count @ + top >type @ array apop >r
+    under r@ under bytes cmove
+    top r@ under bytes + top bytes cmove
+    under under bytes 0 fill
+    top top bytes 0 fill
+    r> apush anip anip
+    exit
+  then
+  top >type @ MIXED = if apop box apush recurse exit then
+  under >type @ MIXED = if box recurse exit then
+  apop apop 2 MIXED array top cell+ ! top !
+;
+: ,c   catenate ;
+
+( Building arrays on the stack. )
+: [[   ap @ ;
+: ]]   ap @ swap - cell/ empty for aft aswap box aswap ,c then next ;
+
+previous previous forth definitions
diff --git a/examples/gemini/gemini.fs b/examples/gemini/gemini.fs
new file mode 100755
index 0000000..b3fa2f3
--- /dev/null
+++ b/examples/gemini/gemini.fs
@@ -0,0 +1,63 @@
+#! /usr/bin/env ueforth
+
+needs arrays.fs
+needs json.fs
+needs slurp.fs
+
+vocabulary gemini also json also arrays also gemini definitions
+
+: askit { a n -- a }
+   {{
+     [[ _s" contents" [[
+       {{
+         [[ _s" parts" [[
+           {{
+             [[ _s" text" a n _s ]]
+           }}
+         ]] ]]
+       }}
+     ]] ]]
+   }}
+;
+
+s" What's the time?" askit >json a.
+
+0 [IF]
+HTTPClient
+NetworkClientSecure.new constant nclient
+
+: 2constant create , , does> dup cell+ @ swap @ ;
+
+: slurp-file ( a n -- a n )
+  r/o open-file throw >r
+  r@ file-size throw ( sz )
+  dup 1+ allocate throw swap ( data sz )
+  2dup r@ read-file throw drop
+  r> close-file throw
+  2dup + 0 swap c!
+;
+
+s" /spiffs/gemini_cert" slurp-file drop constant cacert
+s" /spiffs/gemini_url" slurp-file drop constant url
+s" /spiffs/question" slurp-file 2constant question
+
+cacert nclient NetworkClientSecure.setCACert
+." loaded cert:" cr
+cacert z>s type cr
+
+HTTPClient.new constant session
+." created session" cr
+." URL: " url z>s type cr
+url nclient session HTTPClient.beginNC ." beginNC: " . cr
+1 session HTTPClient.setFollowRedirects
+10 session HTTPClient.setRedirectLimit
+." set follow redirects and limit of 10" cr
+." question: " question type
+z" POST" question session HTTPClient.sendRequest ." POSTED: " . cr
+
+session HTTPClient.getStreamPtr constant result
+result NetworkClient.available ." available: " dup . cr
+
+[THEN]
+
+previous previous previous forth definitions
diff --git a/examples/gemini/json.fs b/examples/gemini/json.fs
new file mode 100755
index 0000000..22547d5
--- /dev/null
+++ b/examples/gemini/json.fs
@@ -0,0 +1,154 @@
+#! /usr/bin/env ueforth
+
+needs arrays.fs
+
+vocabulary json also internals also arrays also json definitions
+
+defer getchar
+-1 value token
+: skip   getchar to token ;
+
+variable insource
+variable inlength
+: in ( a n -- ) inlength ! insource ! skip ;
+: ingetchar ( -- n )
+   inlength @ 0= if -1 exit then
+   insource @ c@ 1 insource +! -1 inlength +! ;
+' ingetchar is getchar
+
+s" DICTIONARY" _s aconstant DICT
+: {{   [[ DICT ;
+: }}   ]] ;
+
+: space? ( ch -- f ) dup 8 = over 10 = or over 13 = or swap 32 = or ;
+: whitespace    begin token space? while skip repeat ;
+: expect ( a n -- ) for aft dup c@ token = assert 1+ skip then next drop ;
+: sliteral ( a n -- ) postpone $@ dup , zplace ;
+: e:   bl parse sliteral postpone expect ; immediate
+
+: escaped
+   e: \
+   token skip case
+     [char] " of [char] " _c catenate endof
+     [char] \ of [char] \ _c catenate endof
+     [char] / of [char] / _c catenate endof
+     [char] b of 8 _c catenate endof
+     [char] n of nl _c catenate endof
+     [char] r of 13 _c catenate endof
+     [char] t of 8 _c catenate endof
+     [char] u of 255 _c catenate skip skip skip skip endof
+     -1 throw
+   endcase
+;
+
+: jstring
+   e: " s" " _s
+   begin token [char] " <> while
+     token [char] \ = if
+       escaped
+     else
+       token _c catenate
+       skip
+     then
+   repeat
+   e: "
+;
+
+defer jvalue
+
+: jobject
+   e: { whitespace
+   DICT box
+   begin
+     token [char] } = if skip exit then
+     jstring box whitespace e: : whitespace jvalue box
+     catenate box catenate
+     token [char] } = if skip exit then
+     e: , whitespace
+   again
+   e: }
+;
+
+: digit? ( -- f ) token [char] 0 >= token [char] 9 <= and ;
+: jdigit   token [char] 0 - skip ;
+: jinteger   digit? assert jdigit
+             begin digit? while 10 * jdigit + repeat ;
+: jfraction   digit? assert 10 * jdigit + >r 1- r>
+              begin digit? while 10 * jdigit + >r 1- r> repeat ;
+: jnumber
+  token [char] - = if skip -1 else 1 then
+  token [char] 0 = if skip 0 else jinteger then 0 swap
+  token [char] . = if skip jfraction then
+  swap >r * r>
+  token [char] e = token [char] E = or if
+    skip
+    token [char] - = if
+      skip -1
+    else
+      token [char] + = if skip then 1
+    then
+    jinteger * +
+  then
+  dup if 10e s>f f** s>f f* _f else drop _i then
+;
+
+: jarray
+   e: [ whitespace
+   0 MIXED array
+   begin
+     token [char] ] = if skip exit then
+     jvalue box catenate whitespace
+     token [char] ] = if skip exit then
+     e: , whitespace
+   again
+;
+
+:noname
+   whitespace
+   token case
+     [char] " of jstring endof
+     [char] { of jobject endof
+     [char] [ of jarray endof
+     [char] t of e: true s" true" _s endof
+     [char] f of e: false s" false" _s endof
+     [char] n of e: null s" null" _s endof
+     jnumber
+   endcase
+   whitespace
+; is jvalue
+
+: json> ( a -- a ) top top >count @ in jvalue anip ;
+
+: butlast? ( n -- f ) top >count @ 1- <> ;
+
+: >json ( a: a -- a )
+  top >type @ case
+    MIXED of
+      top >count @ 1 > if top @ DICT top @ adrop = else 0 then if
+        _s" {" >a top >count @ 1 ?do
+          adup i a@ 0 a@ recurse _s" :" ,c a> aswap ,c >a
+          adup i a@ 1 a@ recurse a> aswap ,c >a
+          i butlast? if a> _s" ," ,c >a then
+        loop a> _s" }" ,c
+      else
+        _s" [" >a top >count @ 0 ?do
+          adup i a@ recurse a> aswap ,c >a
+          i butlast? if a> _s" ," ,c >a then
+        loop a> _s" ]" ,c
+      then
+    endof
+    STRING of [char] " _c >a top top >count @ a> _s ,c [char] " _c ,c endof
+    INTEGER of
+      _s" " >a
+      top >count @ 0 ?do
+        top i cells + @ <# #s #> a> _s"  " ,c _s ,c >a
+      loop a> endof
+    REAL of
+      _s" " >a top >count @ 0 ?do
+        top i sfloats + sf@ <# #fs #> a> _s" " ,c _s ,c >a
+      loop a> endof
+  endcase
+  anip
+;
+
+previous previous previous forth definitions
diff --git a/examples/gemini/slurp.fs b/examples/gemini/slurp.fs
new file mode 100644
index 0000000..a01c491
--- /dev/null
+++ b/examples/gemini/slurp.fs
@@ -0,0 +1,8 @@
+: slurp-file ( a n -- a n )
+  r/o open-file throw >r
+  r@ file-size throw ( sz )
+  dup 1+ allocate throw swap ( data sz )
+  2dup r@ read-file throw drop
+  r> close-file throw
+  2dup + 0 swap c!
+;