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
  31 ;(load "defs.scm") ; csc -prologue defs.scm joy.scm
  32 (cond-expand
  33   (chicken-script (load "defs.scm"))
  34   (else))
  35
  36 (define (joy stack expression dict)
  37   (if (null? expression)
  38     (values stack dict)
  39     (if (string? (car expression))
  40       (receive (s e d)
  41         (joy-eval (car expression) stack (cdr expression) dict)
  42         (joy s e d))
  43       (joy (cons (car expression) stack) (cdr expression) dict))))
  44
  45 (define (joy-eval symbol stack expression dict)
  46   (define (is-it? name) (string=? symbol name))
  47   (cond
  48     ((is-it? "+") ((joy-func +) stack expression dict))
  49     ((is-it? "-") ((joy-func -) stack expression dict))
  50     ((is-it? "*") ((joy-func *) stack expression dict))
  51     ((is-it? "/") ((joy-func quotient) stack expression dict))  ; but for negative divisor, no!?
  52     ((is-it? "%") ((joy-func modulo) stack expression dict))
  53
  54     ((is-it? "add") ((joy-func +) stack expression dict))
  55     ((is-it? "sub") ((joy-func -) stack expression dict))
  56     ((is-it? "mul") ((joy-func *) stack expression dict))
  57     ((is-it? "div") ((joy-func quotient) stack expression dict))  ; but for negative divisor, no!?
  58     ((is-it? "mod") ((joy-func modulo) stack expression dict))
  59
  60     ((is-it? "<") ((joy-func <) stack expression dict))
  61     ((is-it? ">") ((joy-func >) stack expression dict))
  62     ((is-it? "<=") ((joy-func <=) stack expression dict))
  63     ((is-it? ">=") ((joy-func >=) stack expression dict))
  64     ((is-it? "=") ((joy-func =) stack expression dict))
  65     ((is-it? "<>") ((joy-func not-equal) stack expression dict))
  66     ((is-it? "!=") ((joy-func not-equal) stack expression dict))
  67
  68     ((is-it? "dup") (values (cons (car stack) stack) expression dict))
  69     ((is-it? "pop") (values (cdr stack) expression dict))
  70     ((is-it? "stack") (values (cons stack stack) expression dict))
  71     ((is-it? "swaack") (values (cons (cdr stack) (car stack)) expression dict))
  72     ((is-it? "swap") (values (cons (cadr stack) (cons (car stack) (cddr stack))) expression dict))
  73
  74     ((is-it? "concat") ((joy-func append) stack expression dict))
  75     ((is-it? "cons") ((joy-func cons) stack expression dict))
  76     ((is-it? "first") (values (cons (caar stack) (cdr stack)) expression dict))
  77     ((is-it? "rest")  (values (cons (cdar stack) (cdr stack)) expression dict))
  78
  79     ((is-it? "i") (joy-i stack expression dict))
  80     ((is-it? "dip") (joy-dip stack expression dict))
  81     ((is-it? "branch") (joy-branch stack expression dict))
  82     ((is-it? "loop") (joy-loop stack expression dict))
  83
  84     ((hash-table-exists? dict symbol)
  85       (values stack (append (hash-table-ref dict symbol) expression) dict))
  86
  87     (else (error (conc "Unknown word: " symbol)))))
  88
  89 (define (not-equal a b) (not (= a b)))
  90
  91 (define (joy-func op)
  92   (lambda (stack expression dict)
  93     (values (cons (op (cadr stack) (car stack)) (cddr stack)) expression dict)))
  94
  95
  96 (define (joy-i stack expression dict)
  97   (values (cdr stack) (append (car stack) expression) dict))
  98
  99 (define (joy-dip stack expression dict)
 100   (values (cddr stack)
 101           (append (car stack) (cons (cadr stack) expression))
 102           dict))
 103
 104 (define (joy-branch stack expression dict)
 105   (let ((flag (caddr stack))
 106         (false_body (cadr stack))
 107         (true_body (car stack)))
 108     (values (cdddr stack)
 109             (append (if flag true_body false_body) expression)
 110             dict)))
 111
 112 (define (joy-loop stack expression dict)
 113   (let ((flag (cadr stack))
 114         (body (car stack)))
 115     (values (cddr stack)
 116             (if flag (append body (cons body (cons "loop" expression))) expression)
 117             dict)))
 118
 119
 120 (define (string-replace str from to)
 121   (string-intersperse (string-split str from #t) to))
 122
 123 (define (tokenize str)
 124   (string-split
 125     (string-replace (string-replace str "]" " ] ") "[" " [ ")))
 126
 127 (define (tokenator token)
 128   (cond ((string->number token) (string->number token))
 129         ((string=? token "true") #t)
 130         ((string=? token "false") #f)
 131         (else token)))
 132
 133 (define (expect-right-bracket tokens acc)
 134   (if (null? tokens)
 135     (error "Missing closing bracket.")
 136     (expect-right-bracket-lookahead (car tokens) (cdr tokens) acc)))
 137
 138 (define (expect-right-bracket-lookahead token tokens acc)
 139   (cond ((string=? token "]") (values acc tokens))
 140         ((string=? token "[")
 141           (receive (sub_list rest) (expect-right-bracket tokens '())
 142             (receive (el rrest) (expect-right-bracket rest acc)
 143               (values (cons sub_list el) rrest))))
 144         (else
 145           (receive (el rest) (expect-right-bracket tokens acc)
 146             (values (cons (tokenator token) el) rest)))))
 147
 148 (define (one-token-lookahead token tokens)
 149   (cond ((string=? token "]") (error "Extra closing bracket."))
 150         ((string=? token "[") (expect-right-bracket tokens '()))
 151         (else (values (tokenator token) tokens))))
 152
 153 (define (parse0 tokens acc)
 154   (if (null? tokens)
 155     acc
 156     (receive (term rest_of_tokens)
 157       (one-token-lookahead (car tokens) (cdr tokens))
 158       (cons term (parse0 rest_of_tokens acc)))))
 159
 160 (define (parse tokens) (parse0 tokens '()))
 161
 162 (define (text->expression text) (parse (tokenize text)))
 163
 164
 165 (define (joy-term->string term)
 166   (cond ((boolean? term) (if term "true" "false"))
 167         ((number? term) (->string term))
 168         ((list? term) (conc "[" (joy-expression->string term) "]"))
 169         (else term)))
 170
 171 (define (joy-expression->string expr)
 172   (string-intersperse (map joy-term->string expr) " "))
 173
 174
 175 (define (initialize)
 176   (load-defs (make-hash-table string=? string-hash)))
 177
 178 (define (load-defs dict)
 179   (map (lambda (def) (add-def def dict)) (defs))  ;defs is defined in defs.scm
 180   dict)
 181
 182 (define (add-def def dict)
 183   (let ((def_list (text->expression def)))
 184     (hash-table-set! dict (car def_list) (cdr def_list))))
 185
 186
 187 (define (prompt) (display "joy? ") (read-line))
 188
 189 (define DICTIONARY (initialize))
 190 (define STACK '())
 191
 192 (define (doit text)
 193   (receive (stack dict) (joy STACK (text->expression text) DICTIONARY)
 194     (set! DICTIONARY dict)
 195     (set! STACK stack)
 196     (joy-expression->string (reverse stack))))
 197
 198 (define (main-loop)
 199   (let ((text (prompt)))
 200     (if (not (string=? text ""))
 201       ((print (doit text)) (main-loop))
 202       (else))))
 203
 204 (main-loop)
 205
 206
 207 ;(display (doit "5 [] cons [4] concat first"))
 208 ;(display (doit "5 down_to_zero"))
 209 ;(display (doit "1 2 true [4 5 false] loop <"))
 210 ;(newline)
 211