I have ported the whole thing to Scheme (specifically
LIPS Scheme).
Code: Select all
#! /usr/bin/env lips
;; LIPS-Scheme port of Confocaloid's format parser
;; Untested, incomplete, almost certainly buggy, do not reuse, you have been warned.
(load "python.scm")
(define *edges* "0123456789xyz")
(define *corners* "cefghikmn")
(define *faces* "pqrtuvw")
;; Parser
(define (valid-characters? str)
(let* ((allowed (concat *edges* *corners* *faces* "-"))
(used (nodups str))
(invalid (filter (lambda (x) (not (--> allowed (includes x)))) used)))
(if (positive? (length invalid))
(begin
(display "invalid characters: ")
(display invalid)
(newline)
#f)
#t)))
(def (read-part2 str lv2 lv1)
(if (zero? (length str))
(return '(#f ())))
(let ((neg #f))
(when (eq? #\- (string-ref str 0))
(set! neg #t)
(set! str (substring str 1))
(if (zero? (length str))
(return nil)))
(for c in (list *edges* *corners* *faces*)
(if (and (not (eq? c lv1)) (not (eq? c lv2)) (--> c (includes (substring str 0 1))))
(return (list neg (string->list str)))))
nil))
(def (read-list2 str lv2 lv1)
(let* ((poss (fold concat "" (filter (lambda (c) (not (or (eq? c lv1) (eq? c lv2)))) (list *edges* *corners* *faces* "-"))))
(pat (concat "([" lv2 "])([" poss "]*)"))
(out (vector))
(p nil))
(for m in (array->list (Array.from (--> str (matchAll pat))))
(set! p (read-part2 (caddr m) lv2 lv1))
(if (null? p)
(return nil))
(--> out (push (list (car (string->list (cadr m))) p))))
(array->list out)))
(def (read-part1 str lv1)
(if (zero? (length str))
(return '(#f ())))
(let ((neg #f))
(when (eq? #\- (string-ref str 0))
(set! neg #t)
(set! str (substring str 1))
(if (zero? (length str))
(return nil)))
(for c in (list *edges* *corners* *faces*)
(if (and (not (eq? c lv1)) (--> c (includes (substring str 0 1))))
(return (let ((ans (read-list2 str c lv1)))
(if (null? ans) nil (list neg ans))))))
nil))
(def (read-list1 str lv1)
(let* ((poss (fold concat "" (filter (lambda (c) (not (eq? c lv1))) (list *edges* *corners* *faces* "-"))))
(pat (concat "([" lv1 "])([" poss "]*)"))
(out (vector))
(p nil))
(for m in (array->list (Array.from (--> str (matchAll pat))))
(set! p (read-part1 (caddr m) lv1))
(if (null? p)
(return nil))
(--> out (push (list (car (string->list (cadr m))) p))))
(array->list out)))
(def (read-part0 str)
(if (zero? (length str))
(return '(#f ())))
(let ((neg #f))
(when (eq? #\- (string-ref str 0))
(set! neg #t)
(set! str (substring str 1))
(if (zero? (length str))
(return nil)))
(for c in (list *edges* *corners* *faces*)
(if (--> c (includes (substring str 0 1)))
(return (let ((ans (read-list1 str c )))
(if (null? ans) nil (list neg ans))))))
nil))
(define (parse-part0 str)
(set! str (--> str (trim) (toLowerCase)))
(if (valid-characters? str) (read-part0 str) nil))
;; Printer
(def (print-list2 r)
(let* ((head (car r))
(tail (cadr r))
(neg (car tail))
(lst (cadr tail)))
(when (zero? (length lst))
(display head)
(return nil))
(display head)
(display " AND ")
(when neg (display "NOT "))
(display "( ")
(display (join " OR " lst))
(display " )")))
(def (print-list1 r)
(let* ((head (car r))
(tail (cadr r))
(neg (car tail))
(lst (cadr tail)))
(when (zero? (length lst))
(display head)
(return nil))
(display head)
(display " AND ")
(display (if neg "NOT ( " " ( "))
(print-list2 (car lst))
(when (>= (length lst) 2)
(for l in (cdr lst)
(newline)
(display " OR ")
(print-list2 l)))
(display " )")))
(def (print-part0 r)
(let* ((neg (car r))
(lst (cadr r)))
(if (zero? (length lst)) (return))
(display (if neg " NOT ( " " "))
(print-list1 (car lst))
(when (>= (length lst) 2)
(for l in (cdr lst)
(newline)
(display " OR ")
(print-list1 l)))
(when neg (display " )"))))
;; Scheme constructor
(def (make-bool-term items name)
(set! items (filter truthy? items))
(set! items (fold append nil (map (lambda (x) (if (eq? (car x) name) (cdr x) (list x))) items)))
(if (> (length items) 1)
(return `(,name ,@items)))
(if (null? items)
(return nil))
(car items))
(define (make-case x)
`(test ,x))
(define (to-scheme4 parts)
(if (not (null? parts))
(make-bool-term (map make-case parts) 'or)))
(define (to-scheme3 parts)
(let ((part (car parts))
(inverted (caadr parts))
(inner (cadadr parts)))
(set! inner (to-scheme4 inner))
(if inverted
(set! inner `(not ,inner)))
(make-bool-term (list (make-case part) inner) 'and)))
(def (to-scheme2 parts)
(let ((inverted (car parts))
(inner (cadr parts)))
(if (null? inner)
(return nil))
(set! inner (make-bool-term (map to-scheme3 inner) 'or))
(if inverted
`(not ,inner)
inner)))
(define (to-scheme1 part)
(make-bool-term (list (make-case (car part)) (to-scheme2 (cadr part))) 'and))
(define (to-scheme0 part)
(let ((inverted (car part))
(inner (cadr part)))
(set! inner (make-bool-term (map to-scheme1 inner) 'or))
(if inverted
`(not ,inner)
inner)))
;; interface
(define (help)
(print
"Available commands:"
" ? <part-0> Parse a string"
" exit, quit Exit the read-eval-print loop"
" help Print this help"))
(define (main)
(print "Confocaloid's 3D rule explainer 1.0")
(let ((running #t))
(while running
(display ">>> ")
(flush-output)
(let ((input (read-line (current-input-port))))
(set! input (--> input (trim) (toLowerCase)))
(cond
((input.startsWith "?")
(let ((ans (parse-part0 (substring input 1))))
(if (null? ans)
(print "invalid input")
(begin
(print (concat "Scheme: " (repr (to-scheme0 ans))))
(print-part0 ans)
(newline)))))
((string=? "help" input)
(help))
((or (string=? "exit" input) (string=? "quit" input))
(set! running #f))
(else
(print 'nothing-happens))))))
(print 'bye))
(main)
Code: Select all
;; This is python.scm
(define (zip . lists)
"(zip . lists)
Like Python zip() it takes lists (a b c ...)
and returns ((a0 b0 c0 ...) (a1 b1 c1 ...) ...)"
(apply map (cons list lists)))
(define (enumerate l)
"(enumerate l) -> ((0 l0) (1 l1) (2 l2) ...)
Like Python enumerate()"
(zip (range (length l)) l))
(define (nodups c)
"(nodups list)
Returns a new list with the duplicates removed."
(array->list (Array.from (new Set c))))
(define (truthy? x)
"(truthy? x)
Returns #t if the object is Python-truthy"
(cond
((null? x)
#f)
((not x)
#f)
((or (pair? x) (vector? x) (string?) (in "length" x))
(positive? (length x)))
((number? x)
(!= x 0))
(else
#t)))
(define (call-with-exit proc)
"(call-with-exit fn)
Calls fn with a procedure of one argument (the exit procedure), that when called, will
stop execution of fn and cause the call-with-exit to immediately return the value passed
to the exit procedure."
(let* ((s (gensym 'call-with-exit))
(exit (lambda (val) (raise (cons s val)))))
(try (proc exit)
(catch (err)
(if (and (pair? err) (eq? (car err) s))
(cdr err)
(raise err))))))
(define-macro (lambda* params . body)
"(lambda* params . body)
It defines a lambda like (lambda) but can also
do default arguments by specifying pair of (name default).
The default is evaluated every time like Javascript (as opposed to Python).
You can't do rest args like (a b . c), it will break."
(let ((let-list (map (lambda (i p)
(if (symbol? p)
`(,p (nth ,i arguments)) ; if param is required
`(,(car p) (if (> (length arguments) ,i) (nth ,i arguments) ,(cadr p))))) ; if it is optional
(range (length params))
params))
(real-body (if (string? (car body)) (cdr body) body))
(docstring (if (string? (car body)) (list (car body)) '())))
`(lambda arguments ,@docstring (let* ,let-list ,@real-body))))
(define-macro (define* nap . body)
"(define* (name . params) . body)
Like lambda* but as a usual define style macro."
`(define ,(car nap) (lambda* ,(cdr nap) ,@body)))
(define-macro (def nap . body)
"(def (name . params) . body)
Wraps "
(let ((doc nil))
(when (string? (car body))
(set! doc (list (car body)))
(set! body (cdr body)))
`(define* ,nap ,@doc (call-with-exit (lambda (return) ,@body)))))
(define-syntax for
(syntax-rules (in)
((for name in container body ...)
(for-each (lambda (name) body ...) container)))
"(for name in container . body)
Syntax like a Python for loop.
Iterates over the container with name bound to each element of container
and runs the body each time.")
You won't see the >>> prompt due to a
bug in LIPS, but it *should* be the same. LMK if it is not.