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-1)
  30 (import srfi-12)
  31 (import srfi-69)
  32 (import matchable)
  33
  34 ;(load "defs.scm") ; csc -prologue defs.scm joy.scm
  35 (cond-expand
  36   (chicken-script (load "defs.scm"))
  37   (else))
  38
  39
  40 ;██╗███╗   ██╗████████╗███████╗██████╗ ██████╗ ██████╗ ███████╗████████╗███████╗██████╗
  41 ;██║████╗  ██║╚══██╔══╝██╔════╝██╔══██╗██╔══██╗██╔══██╗██╔════╝╚══██╔══╝██╔════╝██╔══██╗
  42 ;██║██╔██╗ ██║   ██║   █████╗  ██████╔╝██████╔╝██████╔╝█████╗     ██║   █████╗  ██████╔╝
  43 ;██║██║╚██╗██║   ██║   ██╔══╝  ██╔══██╗██╔═══╝ ██╔══██╗██╔══╝     ██║   ██╔══╝  ██╔══██╗
  44 ;██║██║ ╚████║   ██║   ███████╗██║  ██║██║     ██║  ██║███████╗   ██║   ███████╗██║  ██║
  45 ;╚═╝╚═╝  ╚═══╝   ╚═╝   ╚══════╝╚═╝  ╚═╝╚═╝     ╚═╝  ╚═╝╚══════╝   ╚═╝   ╚══════╝╚═╝  ╚═╝
  46 ;Interpreter
  47
  48 (define (joy stack expression dict)
  49   ;(joy-trace stack expression)
  50   (if (null? expression)
  51     (values stack dict)
  52     (if (symbol? (car expression))
  53       (receive (s e d)
  54         (joy-eval (car expression) stack (cdr expression) dict)
  55         (joy s e d))
  56       (joy (cons (car expression) stack) (cdr expression) dict))))
  57
  58 (define (joy-eval symbol stack expression dict)
  59   (case symbol
  60     ((+ add) (values (joy-math-func + stack) expression dict))
  61     ((- sub) (values (joy-math-func - stack) expression dict))
  62     ((* mul) (values (joy-math-func * stack) expression dict))
  63     ((/ div) (values (joy-math-func quotient stack) expression dict))  ; but for negative divisor, no!?
  64     ((% mod) (values (joy-math-func modulo stack) expression dict))
  65
  66     ((< lt) (values (joy-math-func < stack) expression dict))
  67     ((> gt) (values (joy-math-func > stack) expression dict))
  68     ((<= le) (values (joy-math-func <= stack) expression dict))
  69     ((>= ge) (values (joy-math-func >= stack) expression dict))
  70     ((= eq) (values (joy-math-func = stack) expression dict))
  71     ((<> != neq) (values (joy-math-func not-equal stack) expression dict))
  72
  73     ((bool) (joy-bool stack expression dict))
  74
  75     ((dup) (values (joy-dup stack) expression dict))
  76     ((pop) (values (cdr stack) expression dict))
  77     ((stack) (values (cons stack stack) expression dict))
  78     ((swaack) (values (cons (cdr stack) (car stack)) expression dict))
  79     ((swap) (values (cons (cadr stack) (cons (car stack) (cddr stack))) expression dict))
  80
  81     ((concat) (joy-func append stack expression dict))
  82     ((cons) (joy-func cons stack expression dict))
  83     ((first) (values (joy-first stack) expression dict))
  84     ((rest)  (values (joy-rest  stack) expression dict))
  85
  86     ((i) (joy-i stack expression dict))
  87     ((dip) (joy-dip stack expression dict))
  88     ((branch) (joy-branch stack expression dict))
  89     ((loop) (joy-loop stack expression dict))
  90
  91     (else (if (hash-table-exists? dict symbol)
  92       (values stack (append (hash-table-ref dict symbol) expression) dict)
  93       (error (conc "Unknown word: " symbol))))))
  94
  95
  96 ;██╗   ██╗████████╗██╗██╗     ███████╗
  97 ;██║   ██║╚══██╔══╝██║██║     ██╔════╝
  98 ;██║   ██║   ██║   ██║██║     ███████╗
  99 ;██║   ██║   ██║   ██║██║     ╚════██║
 100 ;╚██████╔╝   ██║   ██║███████╗███████║
 101 ; ╚═════╝    ╚═╝   ╚═╝╚══════╝╚══════╝
 102 ; Utils
 103
 104 (define (not-equal a b) (not (= a b)))
 105
 106 (define (joy-func op stack expression dict)
 107   (values (cons (op (cadr stack) (car stack)) (cddr stack)) expression dict))
 108
 109 (define (joy-math-func op stack0)
 110   (receive (a stack1) (pop-int stack0)
 111   (receive (b stack) (pop-int stack1)
 112   (cons (op b a) stack))))
 113
 114 (define (pop-any stack)
 115   (if (null-list? stack)
 116     (abort "Not enough values on Stack")
 117     (car+cdr stack)))
 118
 119 (define (pop-kind stack predicate message)
 120   (receive (term rest) (pop-any stack)
 121     (if (predicate term) (values term rest) (abort message))))
 122
 123 (define (pop-list stack) (pop-kind stack list? "Not a list."))
 124 (define (pop-int  stack) (pop-kind stack number? "Not an integer."))
 125 (define (pop-bool stack) (pop-kind stack boolean? "Not a Boolean value."))
 126
 127
 128 ; ██████╗ ██████╗ ██████╗ ███████╗    ██╗    ██╗ ██████╗ ██████╗ ██████╗ ███████╗
 129 ;██╔════╝██╔═══██╗██╔══██╗██╔════╝    ██║    ██║██╔═══██╗██╔══██╗██╔══██╗██╔════╝
 130 ;██║     ██║   ██║██████╔╝█████╗      ██║ █╗ ██║██║   ██║██████╔╝██║  ██║███████╗
 131 ;██║     ██║   ██║██╔══██╗██╔══╝      ██║███╗██║██║   ██║██╔══██╗██║  ██║╚════██║
 132 ;╚██████╗╚██████╔╝██║  ██║███████╗    ╚███╔███╔╝╚██████╔╝██║  ██║██████╔╝███████║
 133 ; ╚═════╝ ╚═════╝ ╚═╝  ╚═╝╚══════╝     ╚══╝╚══╝  ╚═════╝ ╚═╝  ╚═╝╚═════╝ ╚══════╝
 134 ;Core Words
 135
 136 (define (joy-bool stack expression dict)
 137   (values (cons (joy-bool-term (car stack)) (cdr stack)) expression dict))
 138
 139 (define (joy-bool-term term)
 140   (cond ((boolean? term) term)
 141         ((number? term) (not-equal 0 term))
 142         ((list? term) (not (null? term)))
 143         (else #t)))
 144
 145 (define (joy-dup stack)
 146   (receive (term _) (pop-any stack) (cons term stack)))
 147
 148
 149 (define (joy-rest stack0)
 150   (receive (el stack) (pop-list stack0)
 151     (if (null-list? el)
 152       (abort "Cannot take rest of empty list.")
 153       (cons (cdr el) stack))))
 154
 155 (define (joy-first stack0)
 156   (receive (el stack) (pop-list stack0)
 157     (if (null-list? el)
 158       (abort "Cannot take first of empty list.")
 159       (cons (car el) stack))))
 160
 161
 162 ; ██████╗ ██████╗ ███╗   ███╗██████╗ ██╗███╗   ██╗ █████╗ ████████╗ ██████╗ ██████╗ ███████╗
 163 ;██╔════╝██╔═══██╗████╗ ████║██╔══██╗██║████╗  ██║██╔══██╗╚══██╔══╝██╔═══██╗██╔══██╗██╔════╝
 164 ;██║     ██║   ██║██╔████╔██║██████╔╝██║██╔██╗ ██║███████║   ██║   ██║   ██║██████╔╝███████╗
 165 ;██║     ██║   ██║██║╚██╔╝██║██╔══██╗██║██║╚██╗██║██╔══██║   ██║   ██║   ██║██╔══██╗╚════██║
 166 ;╚██████╗╚██████╔╝██║ ╚═╝ ██║██████╔╝██║██║ ╚████║██║  ██║   ██║   ╚██████╔╝██║  ██║███████║
 167 ; ╚═════╝ ╚═════╝ ╚═╝     ╚═╝╚═════╝ ╚═╝╚═╝  ╚═══╝╚═╝  ╚═╝   ╚═╝    ╚═════╝ ╚═╝  ╚═╝╚══════╝
 168 ;Combinators
 169
 170 (define (joy-i stack expression dict)
 171   (values (cdr stack) (append (car stack) expression) dict))
 172
 173 (define (joy-dip stack expression dict)
 174   (values (cddr stack)
 175           (append (car stack) (cons (cadr stack) expression))
 176           dict))
 177
 178 (define (joy-branch stack expression dict)
 179   (let ((flag (caddr stack))
 180         (false_body (cadr stack))
 181         (true_body (car stack)))
 182     (values (cdddr stack)
 183             (append (if flag true_body false_body) expression)
 184             dict)))
 185
 186 (define (joy-loop stack expression dict)
 187   (let ((flag (cadr stack))
 188         (body (car stack)))
 189     (values (cddr stack)
 190             (if flag (append body (cons body (cons "loop" expression))) expression)
 191             dict)))
 192
 193
 194 ;██████╗  █████╗ ██████╗ ███████╗███████╗██████╗
 195 ;██╔══██╗██╔══██╗██╔══██╗██╔════╝██╔════╝██╔══██╗
 196 ;██████╔╝███████║██████╔╝███████╗█████╗  ██████╔╝
 197 ;██╔═══╝ ██╔══██║██╔══██╗╚════██║██╔══╝  ██╔══██╗
 198 ;██║     ██║  ██║██║  ██║███████║███████╗██║  ██║
 199 ;╚═╝     ╚═╝  ╚═╝╚═╝  ╚═╝╚══════╝╚══════╝╚═╝  ╚═╝
 200 ;Parser
 201
 202 (define (string-replace str from to)
 203   (string-intersperse (string-split str from #t) to))
 204
 205 (define (tokenize str)
 206   (string-split
 207     (string-replace (string-replace str "]" " ] ") "[" " [ ")))
 208
 209 (define (tokenator token)
 210   (cond ((string->number token) (string->number token))
 211         ((string=? token "true") #t)
 212         ((string=? token "false") #f)
 213         (else (string->symbol token))))
 214
 215 (define (expect-right-bracket tokens acc)
 216   (if (null? tokens)
 217     (error "Missing closing bracket.")
 218     (expect-right-bracket-lookahead (car tokens) (cdr tokens) acc)))
 219
 220 (define (expect-right-bracket-lookahead token tokens acc)
 221   (match token
 222     ("]" (values acc tokens))
 223     ("[" (receive (sub_list rest) (expect-right-bracket tokens '())
 224            (receive (el rrest) (expect-right-bracket rest acc)
 225              (values (cons sub_list el) rrest))))
 226     (_ (receive (el rest) (expect-right-bracket tokens acc)
 227        (values (cons (tokenator token) el) rest)))))
 228
 229 (define (one-token-lookahead token tokens)
 230   (match token
 231     ("]" (error "Extra closing bracket."))
 232     ("[" (expect-right-bracket tokens '()))
 233     (_ (values (tokenator token) tokens))))
 234
 235 (define (parse0 tokens acc)
 236   (if (null? tokens)
 237     acc
 238     (receive (term rest_of_tokens)
 239       (one-token-lookahead (car tokens) (cdr tokens))
 240       (cons term (parse0 rest_of_tokens acc)))))
 241
 242 (define (parse tokens) (parse0 tokens '()))
 243
 244 (define (text->expression text) (parse (tokenize text)))
 245
 246
 247 ;██████╗ ██████╗ ██╗███╗   ██╗████████╗███████╗██████╗
 248 ;██╔══██╗██╔══██╗██║████╗  ██║╚══██╔══╝██╔════╝██╔══██╗
 249 ;██████╔╝██████╔╝██║██╔██╗ ██║   ██║   █████╗  ██████╔╝
 250 ;██╔═══╝ ██╔══██╗██║██║╚██╗██║   ██║   ██╔══╝  ██╔══██╗
 251 ;██║     ██║  ██║██║██║ ╚████║   ██║   ███████╗██║  ██║
 252 ;╚═╝     ╚═╝  ╚═╝╚═╝╚═╝  ╚═══╝   ╚═╝   ╚══════╝╚═╝  ╚═╝
 253 ;Printer
 254
 255 (define (joy-term->string term)
 256   (cond ((boolean? term) (if term "true" "false"))
 257         ((number? term) (->string term))
 258         ((list? term) (conc "[" (joy-expression->string term) "]"))
 259         (else (symbol->string term))))
 260
 261 (define (joy-expression->string expr)
 262   (string-intersperse (map joy-term->string expr) " "))
 263
 264
 265 ;██████╗ ███████╗███████╗██╗███╗   ██╗██╗████████╗██╗ ██████╗ ███╗   ██╗███████╗
 266 ;██╔══██╗██╔════╝██╔════╝██║████╗  ██║██║╚══██╔══╝██║██╔═══██╗████╗  ██║██╔════╝
 267 ;██║  ██║█████╗  █████╗  ██║██╔██╗ ██║██║   ██║   ██║██║   ██║██╔██╗ ██║███████╗
 268 ;██║  ██║██╔══╝  ██╔══╝  ██║██║╚██╗██║██║   ██║   ██║██║   ██║██║╚██╗██║╚════██║
 269 ;██████╔╝███████╗██║     ██║██║ ╚████║██║   ██║   ██║╚██████╔╝██║ ╚████║███████║
 270 ;╚═════╝ ╚══════╝╚═╝     ╚═╝╚═╝  ╚═══╝╚═╝   ╚═╝   ╚═╝ ╚═════╝ ╚═╝  ╚═══╝╚══════╝
 271 ;Definitions
 272
 273 (define (initialize)
 274   (load-defs! (make-hash-table equal? symbol-hash)))
 275
 276 (define (load-defs! dict)
 277   (for-each (lambda (def) (add-def! def dict)) (defs))
 278   ; defs is defined in defs.scm
 279   dict)
 280
 281 (define (add-def! def dict)
 282   (let ((def_list (text->expression def)))
 283     (hash-table-set! dict (car def_list) (cdr def_list))))
 284
 285
 286 ;██████╗ ███████╗██████╗ ██╗
 287 ;██╔══██╗██╔════╝██╔══██╗██║
 288 ;██████╔╝█████╗  ██████╔╝██║
 289 ;██╔══██╗██╔══╝  ██╔═══╝ ██║
 290 ;██║  ██║███████╗██║     ███████╗
 291 ;╚═╝  ╚═╝╚══════╝╚═╝     ╚══════╝
 292 ;REPL
 293
 294 (define (prompt) (display "joy? ") (read-line))
 295
 296 (define (main-loop stack0 dict0)
 297   (let ((text (prompt)))
 298     (if (eof-object? text)
 299       (print)
 300       (receive (stack dict)
 301         (handle-exceptions exn
 302           (begin (display exn) (newline) (values stack0 dict0))
 303           (joy stack0 (text->expression text) dict0))
 304         (print (joy-expression->string (reverse stack)))
 305         (main-loop stack dict)))))
 306
 307 (define (joy-trace stack expression)
 308   (print (conc (joy-expression->string (reverse stack)) " . " (joy-expression->string expression))))
 309
 310 (main-loop '() (initialize))
 311
 312
 313 ;(display (text->expression "5 [] cons [4] concat first"))
 314 ;(display (doit "5 down_to_zero"))
 315 ;(display (doit "1 2 true [4 5 false] loop <"))
 316 ;(newline)