-
-
Save bakgatviooldoos/f6e91ea926b0fec393c1067cd61bf738 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#lang racket | |
(require (for-syntax syntax/parse | |
racket/syntax) | |
racket/splicing) | |
(define none (string->uninterned-symbol "none")) | |
(define (none? x) (eq? none x)) | |
(struct hash-zipper | |
[head path prev] | |
#:transparent | |
#:property prop:procedure | |
(match-lambda* | |
[`(,self) | |
(error 'hash-zipper | |
(string-append | |
"expected at least one command to the zipper:\n" | |
"~a") | |
self)] | |
[`(,self #:head . ,new-or-nil) | |
(match-define (hash-zipper head path prev) | |
self) | |
(match new-or-nil | |
['() head] | |
[`(,head) (hash-zipper head path prev)])] | |
[`(,self #:path . ,new-or-nil) | |
(match-define (hash-zipper head path prev) | |
self) | |
(match new-or-nil | |
['() path] | |
[`(,path) (hash-zipper head path prev)])] | |
[`(,self #:prev . ,new-or-nil) | |
(match-define (hash-zipper head path prev) | |
self) | |
(match new-or-nil | |
['() prev] | |
[`(,prev) (hash-zipper head path prev)])] | |
[`(,self #:pull ,key) | |
(match-define (hash-zipper head path prev) | |
self) | |
(cond [(not (hash? head)) | |
(error 'hash-zipper | |
(string-append | |
"attempted to pull `~a`:\n" | |
"from `~a`:\n" | |
"expected a hash table in the head of:\n" | |
"~a") | |
key head self)] | |
[else | |
(define pulled (hash-ref head key none)) | |
(define forget (hash-remove head key)) | |
(hash-zipper pulled (cons key path) (cons forget prev))])] | |
[`(,self #:push ,save-or-drop) | |
(match-define (hash-zipper head path prev) | |
self) | |
(match save-or-drop | |
[_ | |
#:when (null? prev) | |
(error 'hash-zipper | |
(string-append | |
"attempted to push `~a`:\n" | |
"at the root of the zipper:\n" | |
"~a") | |
head self)] | |
['save | |
#:when (none? head) | |
(error 'hash-zipper | |
(string-append | |
"attempted to push `none` to the key `~a`:\n" | |
"in `~a`:\n" | |
"expected a value that is not `none`.") | |
(first path) (first prev))] | |
['save | |
(define save (hash-set (first prev) (first path) head)) | |
(hash-zipper save (rest path) (rest prev))] | |
['drop | |
(define drop (first prev)) | |
(hash-zipper drop (rest path) (rest prev))])])) | |
(define (hash:zip [hash #hash()]) (hash-zipper hash '() '())) | |
(define current-zip (make-parameter (hash:zip))) | |
(define-syntax (zip: stx) | |
(define-syntax-class key+val | |
#:attributes (key val) | |
#:datum-literals (∩ ∪) | |
(pattern [key val]) | |
(pattern [key ∩ val]) | |
(pattern [val ∪ key])) | |
(define-syntax-class key×val | |
#:attributes (key val) | |
#:datum-literals (×) | |
(pattern [key × val])) | |
(define-splicing-syntax-class pull-one | |
#:attributes (val [cmd 1]) | |
#:datum-literals (pull) | |
(pattern {~seq pull e:key+val} | |
#:with val #'e.val | |
#:with (cmd ...) #'('#:pull e.key))) | |
(define-splicing-syntax-class pull-many | |
#:attributes (val key) | |
#:datum-literals (pull) | |
(pattern {~seq pull e:key×val} | |
#:with val #'e.val | |
#:with key #'e.key)) | |
(define-syntax-class push-option | |
#:attributes ([cmd 1]) | |
#:datum-literals (save drop) | |
(pattern save | |
#:with (cmd ...) #'('#:push 'save)) | |
(pattern drop | |
#:with (cmd ...) #'('#:push 'drop))) | |
(define-splicing-syntax-class zip-over | |
#:attributes (norm) | |
(pattern {~seq zipper #:over zipper*} | |
#:with norm #'(parameterize ([current-zip zipper]) zipper*)) | |
(pattern {~seq zipper #:over nested:zip-over} | |
#:with norm #'(parameterize ([current-zip zipper]) nested.norm))) | |
(syntax-parse stx | |
#:datum-literals (head path swap focus) | |
[(_ head (~optional val)) | |
#'(~? {current-zip ({current-zip} '#:head val)} | |
(hash-zipper-head {current-zip}))] | |
[(_ path [ptn ...+] | |
#:as (~or* [tmp ...+] [tmp* ...+ . rst])) | |
#'{current-zip | |
(match-let ([(list ptn ...) (hash-zipper-path {current-zip})]) | |
({current-zip} '#:path (~? (list tmp ...) (list* tmp* ... rst))))}] | |
[(_ swap key) | |
#:with ooo #'(... ...) | |
#'(zip: path [_ rest ooo] #:as [key . rest])] | |
[(_ [focus on] | |
body ...) | |
#'(parameterize ([current-zip (if (hash-zipper? on) on (hash:zip on))]) | |
body ...)] | |
[(_ nested:zip-over) | |
#'nested.norm] | |
[(_ open:pull-one | |
body ...) | |
#'(parameterize ([current-zip ({current-zip} open.cmd ...)]) | |
(match-let ([open.val (hash-zipper-head {current-zip})]) | |
body ...))] | |
[(_ open:pull-many | |
(~optional {~seq (~and guard (~or* #:when #:unless)) cond*}) | |
body ...) | |
#'(for/fold ([zipper {current-zip}]) | |
([open.key (in-hash-keys (zip: head))] | |
(~? (~@ guard cond*))) | |
(parameterize ([current-zip zipper]) | |
(zip: pull [open.key open.val] | |
body ...)))] | |
[(_ close:push-option) | |
#'({current-zip} close.cmd ...)])) | |
(let loop ([hash #hash((2 . 1) | |
(1 . 1) | |
(3 . #hash((4 . #hash((5 . 1) | |
(6 . 1))) | |
(5 . 1) | |
(6 . 1) | |
(7 . #hash((8 . 1) | |
(9 . 1))))))]) | |
(zip: [focus hash] | |
(zip: (zip: pull [k × v] | |
#:when (odd? k) | |
(zip: swap (number->string k)) | |
(when (hash? v) (zip: head (loop v))) | |
(zip: save)) | |
#:over | |
(zip: head)))) | |
(zip: (zip: pull ['k v] | |
(when (none? v) (zip: head 200)) | |
(zip: save)) | |
#:over | |
(zip: pull ['k v] | |
(when (none? v) (zip: head 300)) | |
(zip: save)) | |
#:over | |
(zip: head)) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#lang racket | |
(require (for-syntax syntax/parse | |
racket/syntax)) | |
; I "needed" a distinct `none` value | |
(define none (string->uninterned-symbol "none")) | |
(define (none? x) (eq? none x)) | |
;----------------------------------------------------------------------------------- | |
; return a new `hash-zipper` procedure, which allows for the access and modification | |
; of a hash table in a flat[ter], command-by-command style. | |
;----------------------------------------- | |
; head × [keys '()] × [path '()] -> zipper | |
(define (hash-zipper | |
; the "focus" of the zipper. | |
head | |
; the `keys` which resolve to the value of `head` from the root of `path`. | |
[keys '()] | |
; the hashes which contain the `keys` leading to `head`, from the root of `path`. | |
[path '()]) | |
;---------------------------------- | |
; are we at the root of the zipper? | |
(define (root?) (empty? path)) | |
;------------- | |
(match-lambda* | |
;------------------- | |
; return the `head`. | |
; *out of focus*. | |
;--------------- | |
; zipper -> head | |
['(#:pop) head] | |
;------------------- | |
; return the `keys`. | |
; *out of focus*. | |
;--------------- | |
; zipper -> head | |
['(#:keys) keys] | |
;------------------- | |
; return the `path`. | |
; *out of focus*. | |
;--------------- | |
; zipper -> head | |
['(#:path) path] | |
;------------------------------------- | |
; replace the `head` with a new value. | |
; *focused* on `head`. | |
;------------------------ | |
; zipper × head -> zipper | |
[`(#:put ,head) | |
(hash-zipper head keys path)] | |
;-------------------------------------------------------------------------------------- | |
; update the value for the most recent key in `keys` in the most recent hash in `path`, | |
; depending on the value of `choice`. | |
;------------------------------------- | |
; zipper × none | boolean -> error | zipper | |
[`(#:push ,choice) | |
(cond [(root?) | |
(error 'hash-zipper | |
(string-append | |
"attempted to push `~a`\n" | |
"at the root of the zipper.") | |
choice)] | |
[else | |
(define updated | |
(match choice | |
[#true | |
;--------------------------------------------------------------- | |
; set the `head` as the value for the most recent key in `keys`, | |
; in the most recent hash in `path`. | |
(define pushed (hash-set (first path) (first keys) head)) | |
pushed] | |
[#false | |
;------------------------------------------------------------------- | |
; forget the current `head` and remove the most recent key in `keys` | |
; and its value from the most recent hash in `path`. | |
(define dropped (hash-remove (first path) (first keys))) | |
dropped] | |
[(? none?) | |
;-------------------------------------------------------------------- | |
; forget the current `head` and go to the most recent hash in `path`. | |
(define forget (first path)) | |
forget])) | |
; *focused* on the `updated` hash. | |
(hash-zipper updated (rest keys) (rest path))])] | |
;----------------------------------------------------------- | |
; replace the `head` with the value in `head` for the `key`, | |
; and add `key` and `head` to the `keys` and `path` respectively. | |
; *focused* on the value for `key`. | |
;------------------------------- | |
; zipper × key -> error | zipper | |
[`(#:pull ,key) | |
(cond [(not (hash? head)) | |
(error 'hash-zipper | |
(string-append | |
"attempted to pull `~a`\n" | |
"from `~a`:\n" | |
"which is not a hash-table.") | |
key head)] | |
[else | |
(define pulled (hash-ref head key none)) | |
(hash-zipper pulled (cons key keys) (cons head path))])])) | |
(define-syntax (hash-zipper-send stx) | |
;---------------------------------------------- | |
; syntax for an atomic command to the `zipper`. | |
(define-syntax-class mono-word | |
(pattern (~or* #:pop #:keys #:path))) | |
;--------------------------------------------------- | |
; syntax for a command-and-argument to the `zipper`. | |
(define-syntax-class dual-word | |
(pattern (~or* #:put #:push #:pull))) | |
;---------------------------------------------------- | |
; basic syntax for sending a command to the `zipper`, | |
; i.e., a keyword and possibly an argument expression. | |
(define-splicing-syntax-class send-word | |
#:attributes ([cmd 1]) | |
(pattern {~seq word:mono-word} | |
#:with (cmd ...) #'('word)) | |
(pattern {~seq word:dual-word arg:expr} | |
#:with (cmd ...) #'('word arg))) | |
;----------------------------------------------------------------------------------- | |
; syntax for defining a "lexical" identifier for one of the `views` of the `zipper`. | |
(define-splicing-syntax-class view-word | |
#:attributes (name view) | |
#:datum-literals (VIEW) | |
(pattern {~seq VIEW [name*:id view*:mono-word]} | |
#:with name #'name* | |
#:with view #''view*)) | |
;----------------------------------------------------------------------------------- | |
; utility syntax for sending one of the three push command variants to the `zipper`. | |
(define-syntax-class push-word | |
#:attributes ([cmd 1]) | |
#:datum-literals (SAVE DROP BACK) | |
(pattern SAVE #:with (cmd ...) #'('#:push #true)) | |
(pattern DROP #:with (cmd ...) #'('#:push #false)) | |
(pattern BACK #:with (cmd ...) #'('#:push none))) | |
;----------------------------------------------------------------------- | |
; utility syntax for sending common multi-word commands to the `zipper`. | |
(define-splicing-syntax-class compound-word | |
#:attributes ([words 1]) | |
#:datum-literals (LOAD SYNC GRAB PEEK WIPE) | |
; singular (compound) words? | |
(pattern {~seq LOAD [key val]} | |
#:with (words ...) | |
#'(#:pull key #:put val)) | |
; plural (compound) words? | |
(pattern {~seq SYNC ([key val] ...)} | |
#:with (words ...) | |
#'((~@ LOAD [key val] SAVE) ...)) | |
(pattern {~seq GRAB [key name]} | |
#:with (words ...) | |
#'(#:pull key VIEW [name #:pop])) | |
(pattern {~seq PEEK ([key name] ...)} | |
#:with (words ...) | |
#'((~@ GRAB [key name] BACK) ...)) | |
(pattern {~seq WIPE [key ...]} | |
#:with (words ...) | |
#'((~@ #:pull key DROP) ...))) | |
;------------------------------------------------------------------------ | |
; syntax for adding a `meta word` to the context of the `zipper` in-line, | |
; which is a "lexically" defined procedure. | |
; the `meta word` can be called during the execution of further commands. | |
(define-splicing-syntax-class meta-word | |
#:attributes (name proc) | |
#:datum-literals (DEFN) | |
(pattern {~seq DEFN (word:id arg ...) | |
[body ...+]} | |
#:with name #'word | |
#:with proc | |
#'(lambda (arg ...) | |
(lambda (zipper*) | |
(hash-zipper-send | |
zipper* body ...))))) | |
;------------------------------------------------------------------------- | |
; syntax for recognizing a `cond` or `match` style `FORK`-word expression. | |
(define-splicing-syntax-class cond-mode | |
#:attributes (type uses else) | |
#:datum-literals (.ON) | |
(pattern {~seq .ON uses*:expr} | |
#:with type #'match | |
#:with uses #'(uses*) | |
#:with else #'_) | |
(pattern {~seq} | |
#:with type #'cond | |
#:with uses #'() | |
#:with else #'else)) | |
;---------------------------------------------------------------- | |
; syntax for a conditional-branch expression, one branch of which | |
; may be executed, before continuing with the rest of the commands to the `zipper`. | |
(define-splicing-syntax-class cond-word | |
#:attributes | |
(type uses else [cond? 1] [branch 2] [ifelse 1]) | |
#:datum-literals (FORK .IN .OR WHEN UNLESS) | |
(pattern {~seq FORK mode:cond-mode | |
{~seq {~seq .IN [cond?* branch* ...]} | |
...+ | |
(~optional | |
{~seq .OR [else* ...]})}} | |
;------------------------ | |
#:with type #'mode.type | |
#:with uses #'mode.uses | |
#:with else #'mode.else | |
;--------------------------------------- | |
#:with (cond? ...) #'(cond?* ...) | |
#:with ((branch ...) ...) #'((branch* ...) ...) | |
#:with (ifelse ...) #'(~? (else* ...) ())) | |
(pattern {~seq WHEN state:expr | |
[body* ...+]} | |
;------------------------ | |
#:with type #'cond | |
#:with uses #'() | |
#:with else #'else | |
;--------------------------------------- | |
#:with (cond? ...) #'(state) | |
#:with ((branch ...) ...) #'((body* ...)) | |
#:with (ifelse ...) #'()) | |
(pattern {~seq UNLESS state:expr | |
[body* ...+]} | |
;------------------------ | |
#:with type #'cond | |
#:with uses #'() | |
#:with else #'else | |
;--------------------------------------- | |
#:with (cond? ...) #'((not state)) | |
#:with ((branch ...) ...) #'((body* ...)) | |
#:with (ifelse ...) #'())) | |
(define-syntax-class fold-body | |
(pattern (~not (~literal .VALS)))) | |
(define-splicing-syntax-class fold-head | |
#:attributes ([loop 1] [each 1]) | |
#:datum-literals (FOLD .LOOP .EACH EACH) | |
(pattern {~seq FOLD | |
.LOOP (loop* ...+) | |
.EACH (each* ...+)} | |
#:with (loop ...) #'(loop* ...) | |
#:with (each ...) #'(each* ...)) | |
(pattern {~seq EACH (each* ...+)} | |
#:with (loop ...) #'() | |
#:with (each ...) #'(each* ...))) | |
(define-splicing-syntax-class fold-word | |
#:attributes | |
([loop 1] [each 1] [body 1] [vals 1] [last 1]) | |
#:datum-literals (.VALS .LAST) | |
(pattern {~seq head:fold-head | |
[body*:fold-body ...+ | |
(~optional | |
{~seq .VALS [vals* ...+]})] | |
(~optional | |
{~seq .LAST {last* ...+}})} | |
#:with (loop ...) #'(head.loop ...) | |
#:with (each ...) #'(head.each ...) | |
#:with (body ...) #'(body* ...) | |
#:with (vals ...) #'(~? (vals* ...) ()) | |
#:with (last ...) #'(~? (last* ...) ()))) | |
(define-splicing-syntax-class loop-word | |
#:attributes (name proc [with 1]) | |
#:datum-literals (ONCE .WITH) | |
(pattern {~seq ONCE (name* args ...) | |
[body ...+] | |
(~optional | |
{~seq .WITH (with* ...)})} | |
#:with name #'name* | |
#:with proc | |
#'(lambda (args ...) | |
(lambda (zipper*) | |
(hash-zipper-send | |
zipper* body ...))) | |
#:with (with ...) #'(~? (with* ...) ()))) | |
(define-splicing-syntax-class then-word | |
#:attributes ([body 1]) | |
#:datum-literals (THEN .DO .THEN) | |
(pattern .THEN | |
#:with (body ...) #'()) | |
(pattern {~seq THEN .DO times:nat | |
[body* ...+]} | |
#:with (body ...) | |
(for*/list ([_ (in-range (syntax-e #'times))] | |
[part (in-list (syntax->list #'(body* ...)))]) | |
part)) | |
(pattern {~seq THEN .DO times:expr | |
[body* ...+]} | |
#:with (body ...) | |
#'(EACH ([_ (in-range times)]) | |
[body* ...])) | |
(pattern {~seq THEN [body* ...+]} | |
#:with (body ...) #'(body* ...))) | |
(syntax-parse stx | |
#:datum-literals (CALL) | |
;------------------------------------ | |
; do nothing and return the `zipper`. | |
;----------------- | |
; zipper -> zipper | |
[(_ zipper) #'zipper] | |
[(_ zipper | |
word:then-word | |
rest ...) | |
#'(hash-zipper-send | |
zipper word.body ... | |
rest ...)] | |
;---------------------------------------------------------- | |
; replace the `zipper` with the application of `proc` to it | |
; and continue with the rest of the commands. | |
;------------------------------------------------------- | |
; zipper × {proc cmds ...} -> (proc zipper) × {cmds ...} | |
[(_ zipper | |
CALL proc | |
rest ...) | |
#'(hash-zipper-send | |
(proc zipper) rest ...)] | |
[(_ zipper | |
word:fold-word | |
rest ...) | |
#'(hash-zipper-send | |
(for/fold (word.loop ... | |
[zipper* zipper] | |
#:result | |
(hash-zipper-send | |
zipper* word.last ...)) | |
(word.each ...) | |
(values | |
word.vals ... | |
(hash-zipper-send | |
zipper* word.body ...))) | |
rest ...)] | |
; very similar to the `meta words`, except for the "lifetime" of the closure | |
[(_ zipper | |
word:loop-word | |
rest ...) | |
#'(hash-zipper-send | |
(letrec ([word.name word.proc]) | |
((word.name word.with ...) | |
zipper)) | |
rest ...)] | |
;------------------------------------------------------------------------ | |
; send an abbreviated form of common multi-word commands to the `zipper`, | |
; and continue with the rest of the commands. | |
;---------------------------------------------------------- | |
; zipper × {comp cmds ...} -> zipper × {words ... cmds ...} | |
[(_ zipper | |
word:compound-word | |
rest ...) | |
#'(hash-zipper-send | |
zipper word.words ... | |
rest ...)] | |
;---------------------------------------------------------------------- | |
; define a "lexical" identifier for the current `view` of the `zipper`, | |
; i.e., the `head`, `keys`, or `path` of the `zipper`, | |
; and continue with the rest of the commands. | |
;--------------------------------------------------------------------- | |
; zipper × {view cmds ...} -> (let (... view ...) zipper × {cmds ...}) | |
[(_ zipper | |
word:view-word | |
rest ...) | |
#'(let ([word.name (zipper word.view)]) | |
(hash-zipper-send | |
zipper rest ...))] | |
;------------------------------------------------------------------------------------ | |
; send an abbreviated form of one of the three push command variants to the `zipper`, | |
; and continue with the rest of the commands. | |
;------------------------------------------------------------- | |
; zipper × {push* cmds ...} -> zipper × {push choice cmds ...} | |
[(_ zipper | |
word:push-word | |
rest ...) | |
#'(hash-zipper-send | |
(zipper word.cmd ...) | |
rest ...)] | |
;---------------------------------------------------------------------------- | |
; follow one of a given number of conditional branches, depending on `cond?`, | |
; and possibly an optional `.ON uses`, indicating a pattern matching expression, | |
; and continue with the rest of the commands to the `zipper`. | |
;------------------------------------------------------- | |
; zipper × {cond cmds ...} -> zipper × {branch cmds ...} | |
[(_ zipper | |
word:cond-word | |
rest ...) | |
#'(hash-zipper-send | |
(word.type (~@ . word.uses) | |
[word.cond? | |
(hash-zipper-send | |
zipper word.branch ...)] | |
... | |
[word.else | |
(hash-zipper-send | |
zipper word.ifelse ...)]) | |
rest ...)] | |
;--------------------------------------------------------------------- | |
; define a "lexical" `meta word` which can be called as a procedure to | |
; send commands to the `zipper`, | |
; and continue with the rest of the commands to the `zipper`. | |
;------------------------------------------------------------------------ | |
; zipper × {meta cmds ...} -> (letrec (... meta ...) zipper × {cmds ...}) | |
[(_ zipper | |
word:meta-word | |
rest ...) | |
#'(letrec ([word.name word.proc]) | |
(hash-zipper-send | |
zipper rest ...))] | |
;---------------------------------------------------------------------------------- | |
; send a command to the `zipper` consisting of a quoted keyword, and the arguments, | |
; and continue with the rest of the commands. | |
;------------------------------------------------------- | |
; zipper × {send cmds ...} -> (zipper send) × {cmds ...} | |
[(_ zipper | |
word:send-word | |
rest ...) | |
#'(hash-zipper-send | |
(zipper word.cmd ...) | |
rest ...)])) | |
;---------------- | |
; a fresh zipper. | |
;--------------- | |
; void -> zipper | |
(define (<#>) (hash-zipper #hash())) | |
(hash-zipper-send | |
(<#>) | |
SYNC (['a 1] ['b 2]) | |
DEFN (A x) | |
[FORK | |
.IN [(list? x) #:put x] | |
.OR [#:put (list x)] | |
.THEN | |
SAVE] | |
THEN | |
{GRAB ['x x] | |
CALL (A x)} | |
DEFN (B x) | |
[FORK .ON x .IN [`(,y) #:put y] .OR [#:put x] .THEN SAVE] | |
THEN | |
{GRAB ['x x] CALL (B x)} | |
#:pop) | |
(hash-zipper-send | |
(<#>) | |
FOLD .LOOP ([num 0]) | |
.EACH ([key (in-list '(a b c d))]) | |
[LOAD [key #hash()] | |
.VALS | |
[(+ num 1)]] | |
.LAST | |
[#:put 'e | |
THEN | |
{EACH ([_ (in-range num)]) | |
[SAVE]}] | |
#:pop) | |
(define lst '(x y z)) | |
(hash-zipper-send | |
(<#>) | |
DEFN (nest n key val) | |
[THEN | |
{DEFN (save* n) | |
[FORK | |
.IN | |
[(< 0 n) SAVE CALL (save* (- n 1))]]} | |
THEN | |
{DEFN (load* n key val) | |
[FORK .ON n | |
.IN [1 | |
LOAD [key val]] | |
.OR [LOAD [key #hash()] | |
CALL (load* (- n 1) key val)]]} | |
THEN | |
{CALL (load* n key val) | |
CALL (save* n)}] | |
THEN | |
{FOLD | |
.LOOP ([state #false]) | |
.EACH ([k '(x y z)] | |
[v '(X Y Z)]) | |
[THEN | |
{CALL (nest 3 k (cons v state))} | |
.VALS | |
[(not state)]]} | |
VIEW [old #:pop] | |
SYNC (['old old]) | |
EACH ([key (in-list lst)]) | |
[THEN .DO 3 | |
{#:pull key} | |
THEN | |
{VIEW [head #:pop]} | |
THEN | |
{FORK .ON head | |
.IN [`(,sym . #f) #:put (symbol->string sym)] | |
.IN [`(,sym . #t) #:put sym]} | |
THEN .DO 3 | |
{SAVE}] | |
#:pop) | |
(hash-zipper-send | |
(<#>) | |
ONCE (loop n [n* n]) | |
[FORK .ON n | |
.IN [10 | |
THEN .DO (- 10 n*) | |
{SAVE}] | |
.IN [09 | |
LOAD [n (+ n 1)] | |
CALL (loop (+ n 1) n*)] | |
.OR [LOAD [n #hash()] | |
CALL (loop (+ n 1) n*)]] | |
.WITH (0) | |
#:pop) | |
; let's try to capitalize each of the string keys and add 1 to the associated value, | |
; or turn the key into a string if it is a symbol and subtract 1 from the associated value, | |
; and then swap the keys and values (if one of these two cases), in a hash-table of k -> v | |
; string | symbol -> integer | hash | |
(hash-zipper-send | |
(hash-zipper #hash(("x" . 0) | |
("y" . 1) | |
("z" . 2) | |
( a . 5) | |
( b . 6) | |
( c . #hash(("x" . 0) | |
("y" . 1) | |
("z" . 2) | |
( a . #hash(("x" . #hash(("x" . 0) | |
("y" . 1) | |
("z" . 2) | |
( a . 5) | |
( b . 6) | |
( c . 7))) | |
("y" . 1) | |
("z" . 2) | |
( a . 5) | |
( b . 6) | |
( c . 7))) | |
( b . 6) | |
( c . 7))))) | |
ONCE (loop root?) | |
;--------------------- | |
[VIEW [the-hash #:pop] | |
EACH ([(key val) (in-hash the-hash)]) | |
;---- | |
[FORK | |
.ON `(,key ,val) | |
;-------------------------------- | |
.IN [`(,(? string?) ,(? number?)) | |
WIPE [key] | |
SYNC ([(+ val 1) | |
(string-upcase key)])] | |
;-------------------------------- | |
.IN [`(,(? symbol?) ,(? number?)) | |
WIPE [key] | |
SYNC ([(- val 1) | |
(symbol->string key)])] | |
;-------------------- | |
.IN [`(,_ ,(? hash?)) | |
#:pull key | |
CALL (loop #false)]] | |
;------------------- | |
UNLESS root? [SAVE]] | |
.WITH (#true) | |
#:pop) |
for/fold
is really useful. Chef's kiss.
At this point, I feel like the amount of "copying" of Racket into the macro is a good indicator that I am doing too much. I think I'll consider a parameter, next.
Indeed, the parameterization makes a big difference in the macro's readability.
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Redid a couple of things. I feel like there is an interesting parallel to Forth, here (see specifically Dawn).