suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix your soul

Browse Source
This commit is contained in:
Matthew Butterick 2016-04-26 22:18:25 -07:00
parent 283e74446b
commit d46534dfdc
17 changed files with 116 additions and 259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
beautiful-racket-lib/br/define.rkt
View File

@ -222,10 +222,11 @@
#'(define-syntax (_id stx)
(syntax-case stx ()
[(_id . rest)
(let ([expanded-stx (map expand-macro (syntax->list #'rest))])
(let* ([expanded-stx (map expand-macro (syntax->list #'rest))]
[fused-stx #`(#,#'_id #,@expanded-stx)])
(define result
(syntax-case #`(#,#'_id #,@expanded-stx) (LITERAL ...) ;; put id back together with args to make whole pattern
[_pat (syntax-parameterize ([caller-stx (make-rename-transformer #'expanded-stx)])
(syntax-case fused-stx (LITERAL ...) ;; put id back together with args to make whole pattern
[_pat (syntax-parameterize ([caller-stx (make-rename-transformer #'fused-stx)])
_body ...)] ...
[else (raise-syntax-error 'define-cases-inverting (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'_id))]))
(if (not (syntax? result))

14
beautiful-racket/br/demo/hdl/And.tst Normal file
View File

@ -0,0 +1,14 @@
#lang br/demo/hdl/tst
/* and */
load And.hdl,
output-list a, b, out;
set a 0, set b 0,
eval, output;
set a 0, set b 1,
eval, output;
set a 1, set b 0,
eval, output;
set a 1, set b 1,
eval, output;

1
beautiful-racket/br/demo/hdl/Nand-Derived.hdl.rkt
View File

@ -1 +0,0 @@
#lang racket

14
beautiful-racket/br/demo/hdl/Nand.tst Normal file
View File

@ -0,0 +1,14 @@
#lang br/demo/hdl/tst
/* nand */
load Nand.hdl,
output-list a, b, out;
set a 0, set b 0,
eval, output;
set a 0, set b 1,
eval, output;
set a 1, set b 0,
eval, output;
set a 1, set b 1,
eval, output;

10
beautiful-racket/br/demo/hdl/Not.tst Normal file
View File

@ -0,0 +1,10 @@
#lang br/demo/hdl/tst
/* Not */
load Not.hdl,
output-list in, out;
set in 0,
eval, output;
set in 1,
eval, output;

13
beautiful-racket/br/demo/hdl/Not2.hdl.rkt
View File

@ -1,13 +0,0 @@
#lang br/demo/hdl
CHIP And {
IN a, b;
OUT out;
PARTS:
Nand(a=a, b=b, out=nandout);
Not(in=nandout, out=out);
}

14
beautiful-racket/br/demo/hdl/Or.tst Normal file
View File

@ -0,0 +1,14 @@
#lang br/demo/hdl/tst
/* or */
load Or.hdl,
output-list a, b, out;
set a 0, set b 0,
eval, output;
set a 0, set b 1,
eval, output;
set a 1, set b 0,
eval, output;
set a 1, set b 1,
eval, output;

56
beautiful-racket/br/demo/hdl/Xor-test.rkt
View File

@ -1,56 +0,0 @@
#lang br
#|
load Xor.hdl,
output-list a, b, out;
set a 0, set b 0,
eval, output;
set a 0, set b 1,
eval, output;
set a 1, set b 0,
eval, output;
set a 1, set b 1,
eval, output;
|#
(define (vals->text vals)
(string-join (map ~a vals) " | "))
(define (display-values . vals)
(displayln (vals->text vals)))
(define (display-dashes . vals)
(displayln (make-string (string-length (vals->text vals)) #\-)))
(define #'(display-header _val ...)
#'(begin
(apply display-values (list '_val ...))
(apply display-dashes (list '_val ...))))
(define (display-status)
(display-values a b (out)))
(define proc (dynamic-require "Xor.hdl" 'Xor))
(display-header a b out)
(define a #f)
(define b #f)
(define (out)
(keyword-apply proc '(#:a #:b) (list a b) null))
(set! a 0)
(set! b 0)
(display-status)
(set! a 0)
(set! b 1)
(display-status)
(set! a 1)
(set! b 0)
(display-status)
(set! a 1)
(set! b 1)
(display-status)

2
beautiful-racket/br/demo/hdl/Xor.tst
View File

@ -2,7 +2,6 @@
load Xor.hdl,
output-list a, b, out;
/*
set a 0, set b 0,
eval, output;
set a 0, set b 1,
@ -11,4 +10,3 @@ set a 1, set b 0,
eval, output;
set a 1, set b 1,
eval, output;
*/

37
beautiful-racket/br/demo/hdl/Xor0.hdl
View File

@ -1,37 +0,0 @@
#lang racket/base
(provide Xor)
(define Xor
(make-keyword-procedure
(λ (kws kw-args . rest)
(define kw-pairs (map cons kws kw-args))
(let ([a (cdr (assq (string->keyword (format "~a" 'a)) kw-pairs))]
[b (cdr (assq (string->keyword (format "~a" 'b)) kw-pairs))])
(define nota
(let ()
(local-require "Not.hdl")
(Not #:in a)))
(define notb
(let ()
(local-require "Not.hdl")
(Not #:in b)))
(define w1
(let ()
(local-require "And.hdl")
(And #:a a #:b notb)))
(define w2
(let ()
(local-require "And.hdl")
(And #:a nota #:b b)))
(define out
(let ()
(local-require "Or.hdl")
(Or #:a w1 #:b w2)))
out))))
(module+ test
(require rackunit)
(check-equal? (Xor #:a 0 #:b 0) 0)
(check-equal? (Xor #:a 0 #:b 1) 1)
(check-equal? (Xor #:a 1 #:b 0) 1)
(check-equal? (Xor #:a 1 #:b 1) 0))

18
beautiful-racket/br/demo/hdl/Xor1.hdl
View File

@ -1,18 +0,0 @@
#lang s-exp br/demo/hdl/expander
(chip Xor (IN a b)
(OUT out)
(PARTS
(Not [in a] [out nota])
(Not [in b] [out notb])
(And [a a] [b notb] [out w1])
(And [a nota] [b b] [out w2])
(Or [a w1] [b w2] [out out])))
(module+ test
(require rackunit)
(check-equal? (Xor #:a 0 #:b 0) 0)
(check-equal? (Xor #:a 0 #:b 1) 1)
(check-equal? (Xor #:a 1 #:b 0) 1)
(check-equal? (Xor #:a 1 #:b 1) 0))

15
beautiful-racket/br/demo/hdl/Xor2.hdl
View File

@ -1,15 +0,0 @@
#lang br/demo/hdl
CHIP Xor {
IN a, b;
OUT out;
PARTS:
Not(in=a, out=nota);
Not(in=b, out=notb);
And(a=a, b=notb, out=w1);
And(a=nota, b=b, out=w2);
Or(a=w1, b=w2, out=out);
}

32
beautiful-racket/br/demo/hdl/expander-outer.rkt
View File

@ -1,32 +0,0 @@
#lang br
(provide #%top-interaction (rename-out [mb #%module-begin]))
(define #'(mb _arg ...)
#'(#%module-begin
(module treemod br/demo/hdl/expander
_arg ...)
(require 'treemod)
(chip parse-tree)))
(define #'(chip _Chip
(_input-pin ...)
(_output-pin ...)
((_Part [_pin-in _val-id] ... [out _pin-out]) ...))
#'(begin
(provide _Chip)
(define _Chip
(make-keyword-procedure
(λ (kws kw-args . rest)
(define kw-pairs (map cons kws kw-args))
(let ([_input-pin (cdr (assq (string->keyword (format "~a" '_input-pin)) kw-pairs))] ...)
(define _pin-out (call-part _Part [_pin-in _val-id] ...)) ...
(values _output-pin ...)))))))
(define #'(call-part _Part [_pin-in _val-id] ...)
(with-syntax ([part-path (format "~a.hdl" (syntax->datum #'_Part))]
[(kw ...) (map (λ(pi) (string->keyword (format "~a" (syntax->datum pi)))) (syntax->list #'(_pin-in ...)))])
#'(let ()
(local-require (rename-in part-path [_Part local-name]))
(keyword-apply local-name '(kw ...) (list _val-id ...) null))))

24
beautiful-racket/br/demo/hdl/expander0.rkt
View File

@ -1,24 +0,0 @@
#lang br
(provide (all-from-out br) chip call-part)
(define #'(chip _Chip
(_input-pin ...)
(_output-pin ...)
((_Part [_pin-in _val-id] ... [out _pin-out]) ...))
#'(begin
(provide _Chip)
(define _Chip
(make-keyword-procedure
(λ (kws kw-args . rest)
(define kw-pairs (map cons kws kw-args))
(let ([_input-pin (cdr (assq (string->keyword (format "~a" '_input-pin)) kw-pairs))] ...)
(define _pin-out (call-part _Part [_pin-in _val-id] ...)) ...
(values _output-pin ...)))))))
(define #'(call-part _Part [_pin-in _val-id] ...)
(with-syntax ([part-path (format "~a.hdl" (syntax->datum #'_Part))]
[(kw ...) (map (λ(pi) (string->keyword (format "~a" (syntax->datum pi)))) (syntax->list #'(_pin-in ...)))])
#'(let ()
(local-require (rename-in part-path [_Part local-name]))
(keyword-apply local-name '(kw ...) (list _val-id ...) null))))

100
beautiful-racket/br/demo/hdl/tst/expander.rkt
View File

@ -1,47 +1,54 @@
#lang br
(provide #%top-interaction #%module-begin #%datum #%top #%app)
(provide #%top-interaction #%module-begin #%datum (rename-out [my-top #%top]) #%app
(all-defined-out))
(provide tst-program)
(define #'(tst-program _arg ...)
#'(begin _arg ...))
; #%app and #%datum have to be present to make #%top work
(define #'(my-top . id)
#'(begin
(displayln (format "got unbound identifier: ~a" 'id))
(procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
(define-inverting #'(tst-program _arg ...)
#'(begin
_arg ...))
(define-for-syntax private-proc-name (generate-temporary))
(define-for-syntax output-here #'output-here)
(provide load-expr)
;; parse shape: (load-expr "load" Xor.hdl ",")
(define #'(load-expr "load" _filename ",")
(define-inverting #'(header-expr (_filename-string _procname) (_colid ... _outid) ";")
(inject-syntax ([#'output (syntax-local-introduce output-here)])
#'(begin
(provide (all-defined-out))
(define _procname (dynamic-require _filename-string '_procname))
(display-header '_colid ... '_outid)
(define _colid #f) ...
(define (_outid)
(keyword-apply _procname
(map (compose1 string->keyword symbol->string) (list '_colid ...))
(list _colid ...) null))
(define (output)
(display-values _colid ... (_outid))))))
(define-inverting #'(load-expr "load" (_filename-string _procname) ",")
#'(_filename-string _procname))
(define #'(filename _filename)
(inject-syntax ([#'filename-string (symbol->string (syntax->datum #'_filename))]
[#'proc-name (string->symbol (cadr (regexp-match #rx"^(.*)\\.hdl$"(symbol->string (syntax->datum #'_filename)))))])
#'(begin
(define _filename (dynamic-require filename-string 'proc-name)))))
#'(filename-string proc-name)))
(begin-for-syntax
(define (expand-macro mac)
(syntax-disarm (local-expand mac 'expression #f) #f)))
(define-inverting #'(table-expr "output-list" _column-id ...)
#'(_column-id ...))
;; parse shape:
;; (header-expr "output-list" a (comma-id "," b) "," "out" ";")
(provide header-expr)
(define #'(header-expr "output-list" _first-id _comma-id ... "," "out" ";")
(inject-syntax ([#'(_other-id ...) (map expand-macro (syntax->list #'(_comma-id ...)))])
#'(begin
(display-header _first-id _other-id ... out)
(define _first-id #f)
(define _other-id #f) ...
(define (out)
(keyword-apply proc '(#:a #:b) (list a b) null))
)))
(provide comma-id)
(define #'(comma-id "," _id)
#'_id)
(define-cases #'column-id
[#'(_ _colid) #'_colid]
[#'(_ _colid ",") #'_colid])
(define #'(display-header _val ...)
(define #'(display-header _sym ...)
#'(begin
(apply display-values (list '_val ...))
(apply display-dashes (list '_val ...))))
(apply display-values (list _sym ...))
(apply display-dashes (list _sym ...))))
(define (vals->text vals)
(string-join (map ~a vals) " | "))
@ -53,30 +60,23 @@
(displayln (make-string (string-length (vals->text vals)) #\-)))
(provide test-expr)
(define #'(test-expr _first-step _comma-step ... ";")
(inject-syntax ([#'(_other-step ...) (expand-macro #'(_comma-step ...))])
#'(let ()
_first-step
_other-step ...)))
(define-inverting #'(test-expr _step-expr ... ";")
#'(begin
_step-expr ...))
(define-cases #'step-expr
[#'(_ _step) #'_step]
[#'(_ _step ",") #'_step])
(provide step-expr)
(define #'(step-expr _step)
#'_step)
(provide set-expr)
(define #'(set-expr "set" _id _val)
#'(set! _id _val))
(provide comma-step)
(define #'(comma-step "," _step)
#'_step)
(provide eval-expr)
(define #'(eval-expr "eval")
#'(set! result (param-proc)))
#'(void))
#|
(tst-program (load-expr "load" Xor.hdl ",") (header-expr "output-list" a "," b "," out ";") (test-expr (step-expr (set-expr "set" a 0)) "," (step-expr (set-expr "set" b 0)) "," (step-expr (eval-expr "eval")) "," (step-expr (output-expr "output")) ";") (test-expr (step-expr (set-expr "set" a 0)) "," (step-expr (set-expr "set" b 1)) "," (step-expr (eval-expr "eval")) "," (step-expr (output-expr "output")) ";") (test-expr (step-expr (set-expr "set" a 1)) "," (step-expr (set-expr "set" b 0)) "," (step-expr (eval-expr "eval")) "," (step-expr (output-expr "output")) ";") (test-expr (step-expr (set-expr "set" a 1)) "," (step-expr (set-expr "set" b 1)) "," (step-expr (eval-expr "eval")) "," (step-expr (output-expr "output")) ";"))
|#
(define #'(output-expr "output")
#'(output-here))

16
beautiful-racket/br/demo/hdl/tst/parser.rkt
View File

@ -1,18 +1,20 @@
#lang ragg
tst-program : load-expr header-expr test-expr*
tst-program : header-expr test-expr*
load-expr : "load" ID ","
header-expr : load-expr table-expr ";"
header-expr : "output-list" ID comma-id* "," "out" ";"
load-expr : "load" filename ","
comma-id : "," ID
filename : ID
test-expr : step-expr comma-step* ";"
table-expr : "output-list" column-id+
comma-step : "," step-expr
column-id : ID [","]
step-expr : set-expr | eval-expr | output-expr
test-expr : step-expr+ ";"
step-expr : (set-expr | eval-expr | output-expr) [","]
set-expr : "set" ID VAL

2
beautiful-racket/br/demo/hdl/tst/tokenizer.rkt
View File

@ -12,7 +12,7 @@
[(seq "/*" (complement (seq any-string "*/" any-string)) "*/")
(token 'COMMENT lexeme #:skip? #t)]
[(union #\tab #\space #\newline) (get-token input-port)]
[(union "load" "output-list" "set" "eval" "output" "out" (char-set ",;")) lexeme]
[(union "load" "output-list" "set" "eval" "output" (char-set ",;")) lexeme]
[(repetition 1 +inf.0 numeric) (token 'VAL (string->number lexeme))]
[(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) (token 'ID (string->symbol lexeme))]))
(get-token input-port))