implementations/scheme-chicken/joy.scm

   1 ;
   2 ;████████╗██╗  ██╗██╗   ██╗███╗   ██╗
   3 ;╚══██╔══╝██║  ██║██║   ██║████╗  ██║
   4 ;   ██║   ███████║██║   ██║██╔██╗ ██║
   5 ;   ██║   ██╔══██║██║   ██║██║╚██╗██║
   6 ;   ██║   ██║  ██║╚██████╔╝██║ ╚████║
   7 ;   ╚═╝   ╚═╝  ╚═╝ ╚═════╝ ╚═╝  ╚═══╝
   8 ;
   9 ;Copyright © 2023 Simon Forman
  10 ;
  11 ;This file is part of Thun
  12 ;
  13 ;Thun is free software: you can redistribute it and/or modify
  14 ;it under the terms of the GNU General Public License as published by
  15 ;the Free Software Foundation, either version 3 of the License, or
  16 ;(at your option) any later version.
  17 ;
  18 ;Thun is distributed in the hope that it will be useful,
  19 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;GNU General Public License for more details.
  22 ;
  23 ;You should have received a copy of the GNU General Public License
  24 ;along with Thun.  If not see <http://www.gnu.org/licenses/>.
  25 ;
  26
  27 (import (chicken io))
  28 (import (chicken string))
  29 (import srfi-69)
  30 (import matchable)
  31
  32 ;(load "defs.scm") ; csc -prologue defs.scm joy.scm
  33 (cond-expand
  34   (chicken-script (load "defs.scm"))
  35   (else))
  36
  37
  38 ;██╗███╗   ██╗████████╗███████╗██████╗ ██████╗ ██████╗ ███████╗████████╗███████╗██████╗
  39 ;██║████╗  ██║╚══██╔══╝██╔════╝██╔══██╗██╔══██╗██╔══██╗██╔════╝╚══██╔══╝██╔════╝██╔══██╗
  40 ;██║██╔██╗ ██║   ██║   █████╗  ██████╔╝██████╔╝██████╔╝█████╗     ██║   █████╗  ██████╔╝
  41 ;██║██║╚██╗██║   ██║   ██╔══╝  ██╔══██╗██╔═══╝ ██╔══██╗██╔══╝     ██║   ██╔══╝  ██╔══██╗
  42 ;██║██║ ╚████║   ██║   ███████╗██║  ██║██║     ██║  ██║███████╗   ██║   ███████╗██║  ██║
  43 ;╚═╝╚═╝  ╚═══╝   ╚═╝   ╚══════╝╚═╝  ╚═╝╚═╝     ╚═╝  ╚═╝╚══════╝   ╚═╝   ╚══════╝╚═╝  ╚═╝
  44 ;Interpreter
  45
  46 (define (joy stack expression dict)
  47   ;(joy-trace stack expression)
  48   (if (null? expression)
  49     (values stack dict)
  50     (if (string? (car expression))
  51       (receive (s e d)
  52         (joy-eval (car expression) stack (cdr expression) dict)
  53         (joy s e d))
  54       (joy (cons (car expression) stack) (cdr expression) dict))))
  55
  56 (define (joy-eval symbol stack expression dict)
  57   (match symbol
  58     ((or "+" "add") ((joy-func +) stack expression dict))
  59     ((or "-" "sub") ((joy-func -) stack expression dict))
  60     ((or "*" "mul") ((joy-func *) stack expression dict))
  61     ((or "/" "div") ((joy-func quotient) stack expression dict))  ; but for negative divisor, no!?
  62     ((or "%" "mod") ((joy-func modulo) stack expression dict))
  63
  64     ("<" ((joy-func <) stack expression dict))
  65     (">" ((joy-func >) stack expression dict))
  66     ("<=" ((joy-func <=) stack expression dict))
  67     (">=" ((joy-func >=) stack expression dict))
  68     ("=" ((joy-func =) stack expression dict))
  69     ((or "<>" "!=") ((joy-func not-equal) stack expression dict))
  70
  71     ("bool" (joy-bool stack expression dict))
  72
  73     ("dup" (values (cons (car stack) stack) expression dict))
  74     ("pop" (values (cdr stack) expression dict))
  75     ("stack" (values (cons stack stack) expression dict))
  76     ("swaack" (values (cons (cdr stack) (car stack)) expression dict))
  77     ("swap" (values (cons (cadr stack) (cons (car stack) (cddr stack))) expression dict))
  78
  79     ("concat" ((joy-func append) stack expression dict))
  80     ("cons" ((joy-func cons) stack expression dict))
  81     ("first" (values (cons (caar stack) (cdr stack)) expression dict))
  82     ("rest"  (values (cons (cdar stack) (cdr stack)) expression dict))
  83
  84     ("i" (joy-i stack expression dict))
  85     ("dip" (joy-dip stack expression dict))
  86     ("branch" (joy-branch stack expression dict))
  87     ("loop" (joy-loop stack expression dict))
  88
  89     (_ (if (hash-table-exists? dict symbol)
  90       (values stack (append (hash-table-ref dict symbol) expression) dict)
  91       (error (conc "Unknown word: " symbol))))))
  92
  93 (define (not-equal a b) (not (= a b)))
  94
  95 (define (joy-func op)
  96   (lambda (stack expression dict)
  97     (values (cons (op (cadr stack) (car stack)) (cddr stack)) expression dict)))
  98
  99
 100 (define (joy-bool stack expression dict)
 101   (values (cons (joy-bool-term (car stack)) (cdr stack)) expression dict))
 102
 103 (define (joy-bool-term term)
 104   (cond ((boolean? term) term)
 105         ((number? term) (not-equal 0 term))
 106         ((list? term) (not (null? term)))
 107         (else #t)))
 108
 109
 110 ; ██████╗ ██████╗ ███╗   ███╗██████╗ ██╗███╗   ██╗ █████╗ ████████╗ ██████╗ ██████╗ ███████╗
 111 ;██╔════╝██╔═══██╗████╗ ████║██╔══██╗██║████╗  ██║██╔══██╗╚══██╔══╝██╔═══██╗██╔══██╗██╔════╝
 112 ;██║     ██║   ██║██╔████╔██║██████╔╝██║██╔██╗ ██║███████║   ██║   ██║   ██║██████╔╝███████╗
 113 ;██║     ██║   ██║██║╚██╔╝██║██╔══██╗██║██║╚██╗██║██╔══██║   ██║   ██║   ██║██╔══██╗╚════██║
 114 ;╚██████╗╚██████╔╝██║ ╚═╝ ██║██████╔╝██║██║ ╚████║██║  ██║   ██║   ╚██████╔╝██║  ██║███████║
 115 ; ╚═════╝ ╚═════╝ ╚═╝     ╚═╝╚═════╝ ╚═╝╚═╝  ╚═══╝╚═╝  ╚═╝   ╚═╝    ╚═════╝ ╚═╝  ╚═╝╚══════╝
 116 ;Combinators
 117
 118 (define (joy-i stack expression dict)
 119   (values (cdr stack) (append (car stack) expression) dict))
 120
 121 (define (joy-dip stack expression dict)
 122   (values (cddr stack)
 123           (append (car stack) (cons (cadr stack) expression))
 124           dict))
 125
 126 (define (joy-branch stack expression dict)
 127   (let ((flag (caddr stack))
 128         (false_body (cadr stack))
 129         (true_body (car stack)))
 130     (values (cdddr stack)
 131             (append (if flag true_body false_body) expression)
 132             dict)))
 133
 134 (define (joy-loop stack expression dict)
 135   (let ((flag (cadr stack))
 136         (body (car stack)))
 137     (values (cddr stack)
 138             (if flag (append body (cons body (cons "loop" expression))) expression)
 139             dict)))
 140
 141
 142 ;██████╗  █████╗ ██████╗ ███████╗███████╗██████╗
 143 ;██╔══██╗██╔══██╗██╔══██╗██╔════╝██╔════╝██╔══██╗
 144 ;██████╔╝███████║██████╔╝███████╗█████╗  ██████╔╝
 145 ;██╔═══╝ ██╔══██║██╔══██╗╚════██║██╔══╝  ██╔══██╗
 146 ;██║     ██║  ██║██║  ██║███████║███████╗██║  ██║
 147 ;╚═╝     ╚═╝  ╚═╝╚═╝  ╚═╝╚══════╝╚══════╝╚═╝  ╚═╝
 148 ;Parser
 149
 150 (define (string-replace str from to)
 151   (string-intersperse (string-split str from #t) to))
 152
 153 (define (tokenize str)
 154   (string-split
 155     (string-replace (string-replace str "]" " ] ") "[" " [ ")))
 156
 157 (define (tokenator token)
 158   (cond ((string->number token) (string->number token))
 159         ((string=? token "true") #t)
 160         ((string=? token "false") #f)
 161         (else token)))
 162
 163 (define (expect-right-bracket tokens acc)
 164   (if (null? tokens)
 165     (error "Missing closing bracket.")
 166     (expect-right-bracket-lookahead (car tokens) (cdr tokens) acc)))
 167
 168 (define (expect-right-bracket-lookahead token tokens acc)
 169   (match token
 170     ("]" (values acc tokens))
 171     ("[" (receive (sub_list rest) (expect-right-bracket tokens '())
 172            (receive (el rrest) (expect-right-bracket rest acc)
 173              (values (cons sub_list el) rrest))))
 174     (_ (receive (el rest) (expect-right-bracket tokens acc)
 175        (values (cons (tokenator token) el) rest)))))
 176
 177 (define (one-token-lookahead token tokens)
 178   (match token
 179     ("]" (error "Extra closing bracket."))
 180     ("[" (expect-right-bracket tokens '()))
 181     (_ (values (tokenator token) tokens))))
 182
 183 (define (parse0 tokens acc)
 184   (if (null? tokens)
 185     acc
 186     (receive (term rest_of_tokens)
 187       (one-token-lookahead (car tokens) (cdr tokens))
 188       (cons term (parse0 rest_of_tokens acc)))))
 189
 190 (define (parse tokens) (parse0 tokens '()))
 191
 192 (define (text->expression text) (parse (tokenize text)))
 193
 194
 195 ;██████╗ ██████╗ ██╗███╗   ██╗████████╗███████╗██████╗
 196 ;██╔══██╗██╔══██╗██║████╗  ██║╚══██╔══╝██╔════╝██╔══██╗
 197 ;██████╔╝██████╔╝██║██╔██╗ ██║   ██║   █████╗  ██████╔╝
 198 ;██╔═══╝ ██╔══██╗██║██║╚██╗██║   ██║   ██╔══╝  ██╔══██╗
 199 ;██║     ██║  ██║██║██║ ╚████║   ██║   ███████╗██║  ██║
 200 ;╚═╝     ╚═╝  ╚═╝╚═╝╚═╝  ╚═══╝   ╚═╝   ╚══════╝╚═╝  ╚═╝
 201 ;Printer
 202
 203 (define (joy-term->string term)
 204   (cond ((boolean? term) (if term "true" "false"))
 205         ((number? term) (->string term))
 206         ((list? term) (conc "[" (joy-expression->string term) "]"))
 207         (else term)))
 208
 209 (define (joy-expression->string expr)
 210   (string-intersperse (map joy-term->string expr) " "))
 211
 212
 213 ;██████╗ ███████╗███████╗██╗███╗   ██╗██╗████████╗██╗ ██████╗ ███╗   ██╗███████╗
 214 ;██╔══██╗██╔════╝██╔════╝██║████╗  ██║██║╚══██╔══╝██║██╔═══██╗████╗  ██║██╔════╝
 215 ;██║  ██║█████╗  █████╗  ██║██╔██╗ ██║██║   ██║   ██║██║   ██║██╔██╗ ██║███████╗
 216 ;██║  ██║██╔══╝  ██╔══╝  ██║██║╚██╗██║██║   ██║   ██║██║   ██║██║╚██╗██║╚════██║
 217 ;██████╔╝███████╗██║     ██║██║ ╚████║██║   ██║   ██║╚██████╔╝██║ ╚████║███████║
 218 ;╚═════╝ ╚══════╝╚═╝     ╚═╝╚═╝  ╚═══╝╚═╝   ╚═╝   ╚═╝ ╚═════╝ ╚═╝  ╚═══╝╚══════╝
 219 ;Definitions
 220
 221 (define (initialize)
 222   (load-defs! (make-hash-table string=? string-hash)))
 223
 224 (define (load-defs! dict)
 225   (for-each (lambda (def) (add-def! def dict)) (defs))
 226   ; defs is defined in defs.scm
 227   dict)
 228
 229 (define (add-def! def dict)
 230   (let ((def_list (text->expression def)))
 231     (hash-table-set! dict (car def_list) (cdr def_list))))
 232
 233
 234 ;██████╗ ███████╗██████╗ ██╗
 235 ;██╔══██╗██╔════╝██╔══██╗██║
 236 ;██████╔╝█████╗  ██████╔╝██║
 237 ;██╔══██╗██╔══╝  ██╔═══╝ ██║
 238 ;██║  ██║███████╗██║     ███████╗
 239 ;╚═╝  ╚═╝╚══════╝╚═╝     ╚══════╝
 240 ;REPL
 241
 242 (define (prompt) (display "joy? ") (read-line))
 243
 244 (define (main-loop stack0 dict0)
 245   (let ((text (prompt)))
 246     (if (not (eof-object? text))
 247       (receive (stack dict) (joy stack0 (text->expression text) dict0)
 248         (print (joy-expression->string (reverse stack)))
 249         (main-loop stack dict))
 250       (print))))
 251
 252 (define (joy-trace stack expression)
 253   (print (conc (joy-expression->string (reverse stack)) " . " (joy-expression->string expression))))
 254
 255 (main-loop '() (initialize))
 256
 257
 258 ;(display (doit "5 [] cons [4] concat first"))
 259 ;(display (doit "5 down_to_zero"))
 260 ;(display (doit "1 2 true [4 5 false] loop <"))
 261 ;(newline)
 262