scolobb/dds
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Switch utils to Typed Racket.

Browse source
This commit is contained in:
Sergiu Ivanov 2022-03-05 13:41:40 +01:00
parent f62d53ed8f
commit 97d4c18305
2 changed files with 497 additions and 532 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
scribblings/utils.scrbl
View file

@ -1,7 +1,7 @@
#lang scribble/manual #lang scribble/manual
@(require scribble/example racket/sandbox @(require scribble/example racket/sandbox
(for-label typed/racket/base graph (for-label typed/racket/base graph
(submod "../utils.rkt" typed) "../utils.rkt"
(only-in typed/graph Graph) (only-in typed/graph Graph)
(only-in racket/set set) (only-in racket/set set)
(only-in racket/stream stream->list stream-take))) (only-in racket/stream stream->list stream-take)))
@ -14,20 +14,11 @@ This module defines miscellaneous utilities, supporting the other modules of
the package: evaluating sexps, manipulating lists, the package: evaluating sexps, manipulating lists,
@hyperlink["https://orgmode.org/"]{Org-mode} interoperability, etc. @hyperlink["https://orgmode.org/"]{Org-mode} interoperability, etc.
@bold{Note:} I am currently migrating this module to Typed Racket.
This documentation only lists the functions and the types which have already
been converted. However, the typed part is currently hidden in an untyped
module, so you cannot yet use the types directly.
@bold{TODO:} Hyperlinks are currently broken in this document because it
actually documents a submodule. Fix them once the migration to Typed Racket
has reached a fixed point.
@(define utils-evaluator @(define utils-evaluator
(parameterize ([sandbox-output 'string] (parameterize ([sandbox-output 'string]
[sandbox-error-output 'string] [sandbox-error-output 'string]
[sandbox-memory-limit 50]) [sandbox-memory-limit 50])
(make-evaluator 'typed/racket #:requires '((submod "utils.rkt" typed))))) (make-evaluator 'typed/racket #:requires '("utils.rkt"))))
@section{Base types} @section{Base types}

276
utils.rkt
View file

@ -1,20 +1,9 @@
#lang racket #lang typed/racket
;;; dds/utils (require typed/graph typed/rackunit typed-compose typed/racket/stream
;;; Various utilities.
(require
graph
(for-syntax syntax/parse racket/list)) (for-syntax syntax/parse racket/list))
;;; Typed section. (provide
(module typed typed/racket
(require typed/graph typed/rackunit typed-compose typed/racket/stream
(for-syntax syntax/parse racket/list))
(provide
Variable VariableMapping GeneralPair Variable VariableMapping GeneralPair
eval-with eval1-with auto-hash-ref/explicit auto-hash-ref/: eval-with eval1-with auto-hash-ref/explicit auto-hash-ref/:
@ -30,21 +19,21 @@
variable-mapping?) variable-mapping?)
(define-type Variable Symbol) (define-type Variable Symbol)
(define-type (VariableMapping A) (Immutable-HashTable Variable A)) (define-type (VariableMapping A) (Immutable-HashTable Variable A))
(: eval-with (-> (VariableMapping Any) Any AnyValues)) (: eval-with (-> (VariableMapping Any) Any AnyValues))
(define (eval-with ht expr) (define (eval-with ht expr)
(parameterize ([current-namespace (make-base-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
(for ([(x val) (in-hash ht)]) (namespace-set-variable-value! x val)) (for ([(x val) (in-hash ht)]) (namespace-set-variable-value! x val))
(eval expr))) (eval expr)))
(: eval1-with (-> (VariableMapping Any) Any Any)) (: eval1-with (-> (VariableMapping Any) Any Any))
(define (eval1-with ht expr) (define (eval1-with ht expr)
(call-with-values (λ () (eval-with ht expr)) (call-with-values (λ () (eval-with ht expr))
(λ args (car args)))) (λ args (car args))))
(module+ test (module+ test
(test-case "eval-with" (test-case "eval-with"
(check-equal? (eval1-with (hash 'a 1 'b 2) '(+ a b 1)) (check-equal? (eval1-with (hash 'a 1 'b 2) '(+ a b 1))
4) 4)
@ -53,14 +42,14 @@
(check-equal? (eval1-with ht expr) (check-equal? (eval1-with ht expr)
4))) 4)))
(define-syntax (auto-hash-ref/explicit stx) (define-syntax (auto-hash-ref/explicit stx)
(syntax-parse stx (syntax-parse stx
[(_ (ht:id keys:id ...) body:expr) [(_ (ht:id keys:id ...) body:expr)
#`(let #,(for/list ([key (syntax->list #'(keys ...))]) #`(let #,(for/list ([key (syntax->list #'(keys ...))])
`[,key (hash-ref ,#'ht ',key)]) `[,key (hash-ref ,#'ht ',key)])
body)])) body)]))
(module+ test (module+ test
(test-case "auto-hash-ref/explicit" (test-case "auto-hash-ref/explicit"
(define mytable #hash((a . 3) (b . 4))) (define mytable #hash((a . 3) (b . 4)))
(check-equal? (auto-hash-ref/explicit (mytable b a) (check-equal? (auto-hash-ref/explicit (mytable b a)
@ -71,8 +60,8 @@
(and (not a) b)) (and (not a) b))
#f))) #f)))
;;; Helper functions for auto-hash-ref/:. ;;; Helper functions for auto-hash-ref/:.
(begin-for-syntax (begin-for-syntax
(define (colon? s) (define (colon? s)
(and (symbol? s) (and (symbol? s)
(eq? (string-ref (symbol->string s) 0) #\:))) (eq? (string-ref (symbol->string s) 0) #\:)))
@ -85,7 +74,7 @@
(define (strip-colon s) (define (strip-colon s)
(string->symbol (substring (symbol->string s) 1)))) (string->symbol (substring (symbol->string s) 1))))
(define-syntax (auto-hash-ref/: stx) (define-syntax (auto-hash-ref/: stx)
(syntax-parse stx (syntax-parse stx
[(_ ht:id body:expr) [(_ ht:id body:expr)
(define colons (collect-colons (syntax->datum stx))) (define colons (collect-colons (syntax->datum stx)))
@ -94,7 +83,7 @@
(with-syntax ([bindings-stx (datum->syntax stx bindings)]) (with-syntax ([bindings-stx (datum->syntax stx bindings)])
#'(let bindings-stx body))])) #'(let bindings-stx body))]))
(module+ test (module+ test
(test-case "auto-hash-ref/:" (test-case "auto-hash-ref/:"
(define ht1 #hash((x . #t) (y . #t) (t . #f))) (define ht1 #hash((x . #t) (y . #t) (t . #f)))
(define z #t) (define z #t)
@ -105,8 +94,8 @@
(check-equal? (auto-hash-ref/: ht2 (+ :a (* 2 :b))) (check-equal? (auto-hash-ref/: ht2 (+ :a (* 2 :b)))
5))) 5)))
(: extract-symbols (-> Any (Listof Symbol))) (: extract-symbols (-> Any (Listof Symbol)))
(define (extract-symbols form) (define (extract-symbols form)
(: extract-rec (-> Any (Listof Any))) (: extract-rec (-> Any (Listof Any)))
(define (extract-rec form) (define (extract-rec form)
(match form (match form
@ -118,93 +107,93 @@
[else '()])) [else '()]))
(cast (extract-rec form) (Listof Symbol))) (cast (extract-rec form) (Listof Symbol)))
(module+ test (module+ test
(test-case "extract-symbols" (test-case "extract-symbols"
(check-equal? (extract-symbols '(1 (2 3) x (y z 3))) (check-equal? (extract-symbols '(1 (2 3) x (y z 3)))
'(x y z)))) '(x y z))))
(: any->string (-> Any String)) (: any->string (-> Any String))
(define (any->string x) (define (any->string x)
(with-output-to-string (λ () (display x)))) (with-output-to-string (λ () (display x))))
(module+ test (module+ test
(test-case "any->string" (test-case "any->string"
(check-equal? (any->string 'a) "a") (check-equal? (any->string 'a) "a")
(check-equal? (any->string '(a 1 (x y))) "(a 1 (x y))") (check-equal? (any->string '(a 1 (x y))) "(a 1 (x y))")
(check-equal? (any->string "hello") "hello"))) (check-equal? (any->string "hello") "hello")))
(: stringify-variable-mapping (-> (VariableMapping Any) (VariableMapping String))) (: stringify-variable-mapping (-> (VariableMapping Any) (VariableMapping String)))
(define (stringify-variable-mapping ht) (define (stringify-variable-mapping ht)
(for/hash : (VariableMapping String) (for/hash : (VariableMapping String)
([(key val) (in-hash ht)]) (values key (any->string val)))) ([(key val) (in-hash ht)]) (values key (any->string val))))
(module+ test (module+ test
(test-case "stringify-variable-mapping" (test-case "stringify-variable-mapping"
(define mp (stringify-variable-mapping #hash((a . (and a b)) (b . (not b))))) (define mp (stringify-variable-mapping #hash((a . (and a b)) (b . (not b)))))
(check-equal? (hash-ref mp 'a) "(and a b)") (check-equal? (hash-ref mp 'a) "(and a b)")
(check-equal? (hash-ref mp 'b) "(not b)"))) (check-equal? (hash-ref mp 'b) "(not b)")))
(: string->any (-> String Any)) (: string->any (-> String Any))
(define (string->any str) (define (string->any str)
(with-input-from-string str (λ () (read)))) (with-input-from-string str (λ () (read))))
(module+ test (module+ test
(test-case "string->any" (test-case "string->any"
(check-equal? (string->any "(or b (not a))") '(or b (not a))) (check-equal? (string->any "(or b (not a))") '(or b (not a)))
(check-equal? (string->any "14") 14))) (check-equal? (string->any "14") 14)))
;;; Given a sexp, converts all "#f" to #f and "#t" to #t. ;;; Given a sexp, converts all "#f" to #f and "#t" to #t.
;;; ;;;
;;; When I read Org-mode tables, I pump them through a call to the ;;; When I read Org-mode tables, I pump them through a call to the
;;; prin1 because the Elisp sexps seems incompatible with Racket. ;;; prin1 because the Elisp sexps seems incompatible with Racket.
;;; On the other hand, Racket Booleans seem to upset Elisp a little, ;;; On the other hand, Racket Booleans seem to upset Elisp a little,
;;; so prin1 wraps them in additional double quotes. This function ;;; so prin1 wraps them in additional double quotes. This function
;;; removes those quotes. ;;; removes those quotes.
(: handle-org-booleans (-> Any Any)) (: handle-org-booleans (-> Any Any))
(define/match (handle-org-booleans datum) (define/match (handle-org-booleans datum)
[("#t") #t] [("#t") #t]
[("#f") #f] [("#f") #f]
[((? list?)) (map handle-org-booleans datum)] [((? list?)) (map handle-org-booleans datum)]
[ (_) datum]) [ (_) datum])
(module+ test (module+ test
(test-case "handle-org-booleans" (test-case "handle-org-booleans"
(check-equal? (handle-org-booleans "#t") #t) (check-equal? (handle-org-booleans "#t") #t)
(check-equal? (handle-org-booleans "#f") #f) (check-equal? (handle-org-booleans "#f") #f)
(check-equal? (handle-org-booleans '("#t" "#f")) '(#t #f)) (check-equal? (handle-org-booleans '("#t" "#f")) '(#t #f))
(check-equal? (handle-org-booleans "t") "t"))) (check-equal? (handle-org-booleans "t") "t")))
(: map-sexp (-> (-> Any Any) Any Any)) (: map-sexp (-> (-> Any Any) Any Any))
(define (map-sexp func sexp) (define (map-sexp func sexp)
(match sexp (match sexp
[(? list?) (map ((curry map-sexp) func) sexp)] [(? list?) (map ((curry map-sexp) func) sexp)]
[datum (func datum)])) [datum (func datum)]))
(module+ test (module+ test
(test-case "map-sexp" (test-case "map-sexp"
(check-equal? (map-sexp (λ (x) (add1 (cast x Number))) '(1 2 (4 10) 3)) (check-equal? (map-sexp (λ (x) (add1 (cast x Number))) '(1 2 (4 10) 3))
'(2 3 (5 11) 4)))) '(2 3 (5 11) 4))))
(: read-org-sexp (-> String Any)) (: read-org-sexp (-> String Any))
(define read-org-sexp (define read-org-sexp
(compose ((curry map-sexp) (match-lambda (compose ((curry map-sexp) (match-lambda
[(and (? string?) str) (string->any str)] [(and (? string?) str) (string->any str)]
[x x])) [x x]))
string->any)) string->any))
(define unorg read-org-sexp) (define unorg read-org-sexp)
(module+ test (module+ test
(test-case "read-org-sexp" (test-case "read-org-sexp"
(check-equal? (read-org-sexp "((\"a\" \"(and a b)\") (\"b\" \"(or b (not a))\"))") (check-equal? (read-org-sexp "((\"a\" \"(and a b)\") (\"b\" \"(or b (not a))\"))")
'((a (and a b)) (b (or b (not a))))) '((a (and a b)) (b (or b (not a)))))
(check-equal? (unorg "(#t \"#t\" \"#t \" '(1 2 \"#f\"))") (check-equal? (unorg "(#t \"#t\" \"#t \" '(1 2 \"#f\"))")
'(#t #t #t '(1 2 #f))))) '(#t #t #t '(1 2 #f)))))
(define-type (GeneralPair A B) (U (Pair A B) (List A B))) (define-type (GeneralPair A B) (U (Pair A B) (List A B)))
(: unstringify-pairs (-> (Listof (GeneralPair String Any)) (: unstringify-pairs (-> (Listof (GeneralPair String Any))
(Listof (GeneralPair Symbol Any)))) (Listof (GeneralPair Symbol Any))))
(define (unstringify-pairs pairs) (define (unstringify-pairs pairs)
(for/list ([p pairs]) (for/list ([p pairs])
(match p (match p
[(list key val) [(list key val)
@ -216,15 +205,15 @@
(string->any val) (string->any val)
val))]))) val))])))
(module+ test (module+ test
(test-case "unstringify-pairs" (test-case "unstringify-pairs"
(check-equal? (unstringify-pairs '(("a" . "1") ("b" . "(and a (not b))"))) (check-equal? (unstringify-pairs '(("a" . "1") ("b" . "(and a (not b))")))
'((a . 1) (b . (and a (not b))))) '((a . 1) (b . (and a (not b)))))
(check-equal? (unstringify-pairs '(("a" . 1) ("b" . "(and a (not b))"))) (check-equal? (unstringify-pairs '(("a" . 1) ("b" . "(and a (not b))")))
'((a . 1) (b . (and a (not b))))))) '((a . 1) (b . (and a (not b)))))))
(: read-org-variable-mapping (-> String (VariableMapping Any))) (: read-org-variable-mapping (-> String (VariableMapping Any)))
(define read-org-variable-mapping (define read-org-variable-mapping
(multi-compose (multi-compose
(λ ([pairs : (Listof (Pair Symbol Any))]) (λ ([pairs : (Listof (Pair Symbol Any))])
(make-immutable-hash pairs)) (make-immutable-hash pairs))
@ -232,10 +221,10 @@
(unstringify-pairs (cast sexp (Listof (GeneralPair String Any))))) (unstringify-pairs (cast sexp (Listof (GeneralPair String Any)))))
string->any)) string->any))
;;; A synonym for read-org-variable-mapping. ;;; A synonym for read-org-variable-mapping.
(define unorgv read-org-variable-mapping) (define unorgv read-org-variable-mapping)
(module+ test (module+ test
(test-case "read-org-variable-mapping" (test-case "read-org-variable-mapping"
(define m1 (read-org-variable-mapping "((\"a\" \"(and a b)\") (\"b\" \"(or b (not a))\"))")) (define m1 (read-org-variable-mapping "((\"a\" \"(and a b)\") (\"b\" \"(or b (not a))\"))"))
(define m2 (read-org-variable-mapping "((\"a\" . \"(and a b)\") (\"b\" . \"(or b (not a))\"))")) (define m2 (read-org-variable-mapping "((\"a\" . \"(and a b)\") (\"b\" . \"(or b (not a))\"))"))
@ -247,61 +236,61 @@
(check-equal? (hash-ref m2 'b) '(or b (not a))) (check-equal? (hash-ref m2 'b) '(or b (not a)))
(check-equal? (hash-ref m3 'b) '(or b (not a))))) (check-equal? (hash-ref m3 'b) '(or b (not a)))))
(: read-symbol-list (-> String (Listof Symbol))) (: read-symbol-list (-> String (Listof Symbol)))
(define (read-symbol-list str) (define (read-symbol-list str)
(cast (string->any (string-append "(" str ")")) (Listof Symbol))) (cast (string->any (string-append "(" str ")")) (Listof Symbol)))
(module+ test (module+ test
(test-case "read-symbol-list" (test-case "read-symbol-list"
(check-equal? (read-symbol-list "a b c") '(a b c)))) (check-equal? (read-symbol-list "a b c") '(a b c))))
(: drop-first-last (-> String String)) (: drop-first-last (-> String String))
(define (drop-first-last str) (define (drop-first-last str)
(substring str 1 (- (string-length str) 1))) (substring str 1 (- (string-length str) 1)))
(module+ test (module+ test
(test-case "drop-first-last" (test-case "drop-first-last"
(check-equal? (drop-first-last "(a b)") "a b"))) (check-equal? (drop-first-last "(a b)") "a b")))
(: list-sets->list-strings (-> (Listof (Setof Any)) (Listof String))) (: list-sets->list-strings (-> (Listof (Setof Any)) (Listof String)))
(define (list-sets->list-strings lst) (define (list-sets->list-strings lst)
(map (multi-compose drop-first-last (map (multi-compose drop-first-last
any->string any->string
(λ ([x : (Setof Any)]) (λ ([x : (Setof Any)])
(set->list x))) lst)) (set->list x))) lst))
(module+ test (module+ test
(test-case "list-sets->list-strings" (test-case "list-sets->list-strings"
(check-equal? (list-sets->list-strings (list (set 'x 'y) (set 'z) (set) (set 't))) (check-equal? (list-sets->list-strings (list (set 'x 'y) (set 'z) (set) (set 't)))
'("x y" "z" "" "t")))) '("x y" "z" "" "t"))))
(: pretty-print-set (-> (Setof Any) String)) (: pretty-print-set (-> (Setof Any) String))
(define (pretty-print-set s) (define (pretty-print-set s)
(string-join (sort (set-map s any->string) string<?))) (string-join (sort (set-map s any->string) string<?)))
(module+ test (module+ test
(test-case "pretty-print-set" (test-case "pretty-print-set"
(check-equal? (pretty-print-set (set 'a 'b 1)) "1 a b"))) (check-equal? (pretty-print-set (set 'a 'b 1)) "1 a b")))
(: pretty-print-set-sets (-> (Setof (Setof Any)) String)) (: pretty-print-set-sets (-> (Setof (Setof Any)) String))
(define (pretty-print-set-sets ms) (define (pretty-print-set-sets ms)
(string-join (for/list ([m ms]) : (Listof String) (string-join (for/list ([m ms]) : (Listof String)
(format "{~a}" (pretty-print-set m))) "")) (format "{~a}" (pretty-print-set m))) ""))
(module+ test (module+ test
(test-case "pretty-print-set-sets" (test-case "pretty-print-set-sets"
(check-equal? (pretty-print-set-sets (set (set 'a 'b) (set 'c))) "{a b}{c}"))) (check-equal? (pretty-print-set-sets (set (set 'a 'b) (set 'c))) "{a b}{c}")))
(define dotit (compose display graphviz)) (define dotit (compose display graphviz))
(: update-vertices/unweighted (-> Graph (-> Any Any) Graph)) (: update-vertices/unweighted (-> Graph (-> Any Any) Graph))
(define (update-vertices/unweighted gr func) (define (update-vertices/unweighted gr func)
(unweighted-graph/directed (unweighted-graph/directed
(for/list ([e (in-edges gr)]) (for/list ([e (in-edges gr)])
(match-let ([(list u v) e]) (match-let ([(list u v) e])
(list (func u) (func v)))))) (list (func u) (func v))))))
(module+ test (module+ test
(test-case "update-vertices/unweighted" (test-case "update-vertices/unweighted"
(define gr1 (directed-graph '((a b) (b c)))) (define gr1 (directed-graph '((a b) (b c))))
(define gr2 (undirected-graph '((a b) (b c)))) (define gr2 (undirected-graph '((a b) (b c))))
@ -325,8 +314,8 @@
(check-true (has-edge? new-gr2 'bb 'cc)) (check-true (has-edge? new-gr2 'bb 'cc))
(check-true (has-edge? new-gr2 'cc 'bb)))) (check-true (has-edge? new-gr2 'cc 'bb))))
(: update-graph (->* (Graph) (#:v-func (-> Any Any) #:e-func (-> Any Any)) Graph)) (: update-graph (->* (Graph) (#:v-func (-> Any Any) #:e-func (-> Any Any)) Graph))
(define (update-graph gr #:v-func [v-func identity] #:e-func [e-func identity]) (define (update-graph gr #:v-func [v-func identity] #:e-func [e-func identity])
(cond (cond
[(unweighted-graph? gr) [(unweighted-graph? gr)
(unweighted-graph/directed (unweighted-graph/directed
@ -340,7 +329,7 @@
(list (e-func (edge-weight gr u v)) (list (e-func (edge-weight gr u v))
(v-func u) (v-func v)))))])) (v-func u) (v-func v)))))]))
(module+ test (module+ test
(test-case "update-graph" (test-case "update-graph"
(define gr1 (directed-graph '((a b) (b c)))) (define gr1 (directed-graph '((a b) (b c))))
(define gr2 (undirected-graph '((a b) (b c)))) (define gr2 (undirected-graph '((a b) (b c))))
@ -375,9 +364,9 @@
(check-equal? (edge-weight new-gr3 'aa 'bb) 20) (check-equal? (edge-weight new-gr3 'aa 'bb) 20)
(check-equal? (edge-weight new-gr3 'bb 'cc) 22))) (check-equal? (edge-weight new-gr3 'bb 'cc) 22)))
(: collect-by-key (All (a b) (-> (Listof a) (Listof b) (: collect-by-key (All (a b) (-> (Listof a) (Listof b)
(Values (Listof a) (Listof (Listof b)))))) (Values (Listof a) (Listof (Listof b))))))
(define (collect-by-key keys vals) (define (collect-by-key keys vals)
(for/fold ([ht : (HashTable a (Listof b)) (for/fold ([ht : (HashTable a (Listof b))
(make-immutable-hash)] (make-immutable-hash)]
#:result (values (hash-keys ht) (hash-values ht))) #:result (values (hash-keys ht) (hash-values ht)))
@ -385,48 +374,48 @@
[l vals]) [l vals])
((inst hash-update a (Listof b)) ht e (λ (ls) (cons l ls)) (λ () empty)))) ((inst hash-update a (Listof b)) ht e (λ (ls) (cons l ls)) (λ () empty))))
(module+ test (module+ test
(test-case "collect-by-key" (test-case "collect-by-key"
(define-values (e1 l1) (collect-by-key '((1 2) (1 3)) '(a b))) (define-values (e1 l1) (collect-by-key '((1 2) (1 3)) '(a b)))
(define-values (e2 l2) (collect-by-key '((1 2) (1 2)) '(a b))) (define-values (e2 l2) (collect-by-key '((1 2) (1 2)) '(a b)))
(check-equal? e1 '((1 2) (1 3))) (check-equal? l1 '((a) (b))) (check-equal? e1 '((1 2) (1 3))) (check-equal? l1 '((a) (b)))
(check-equal? e2 '((1 2))) (check-equal? l2 '((b a))))) (check-equal? e2 '((1 2))) (check-equal? l2 '((b a)))))
(: collect-by-key/sets (All (a b) (-> (Listof a) (Listof b) (: collect-by-key/sets (All (a b) (-> (Listof a) (Listof b)
(Values (Listof a) (Listof (Setof b)))))) (Values (Listof a) (Listof (Setof b))))))
(define (collect-by-key/sets edges labels) (define (collect-by-key/sets edges labels)
(define-values (es ls) (collect-by-key edges labels)) (define-values (es ls) (collect-by-key edges labels))
(values es ((inst map (Setof b) (Listof b)) list->set ls))) (values es ((inst map (Setof b) (Listof b)) list->set ls)))
(module+ test (module+ test
(test-case "collect-by-key/sets" (test-case "collect-by-key/sets"
(define-values (e3 l3) (collect-by-key/sets '(a b a) '(1 2 1))) (define-values (e3 l3) (collect-by-key/sets '(a b a) '(1 2 1)))
(check-equal? e3 '(b a)) (check-equal? l3 (list (set 2) (set 1))))) (check-equal? e3 '(b a)) (check-equal? l3 (list (set 2) (set 1)))))
;;; Converts the values of a hash table from lists to sets. ;;; Converts the values of a hash table from lists to sets.
(: ht-values/list->set (All (a b) (-> (HashTable a (Listof b)) (HashTable a (Setof b))))) (: ht-values/list->set (All (a b) (-> (HashTable a (Listof b)) (HashTable a (Setof b)))))
(define (ht-values/list->set ht) (define (ht-values/list->set ht)
(for/hash ([(k v) (in-hash ht)]) : (HashTable a (Setof b)) (for/hash ([(k v) (in-hash ht)]) : (HashTable a (Setof b))
(values k (list->set v)))) (values k (list->set v))))
(module+ test (module+ test
(test-case "ht-values/list->set" (test-case "ht-values/list->set"
(check-equal? (ht-values/list->set #hash((a . (1 1)))) (check-equal? (ht-values/list->set #hash((a . (1 1))))
(hash 'a (set 1))))) (hash 'a (set 1)))))
;; TODO: Remove after Racket 8.4. ;; TODO: Remove after Racket 8.4.
(: hash->list/ordered (All (a b) (-> (HashTable a b) (Listof (Pairof a b))))) (: hash->list/ordered (All (a b) (-> (HashTable a b) (Listof (Pairof a b)))))
(define (hash->list/ordered ht) (define (hash->list/ordered ht)
((inst hash-map a b (Pairof a b)) ht cons #t)) ((inst hash-map a b (Pairof a b)) ht cons #t))
(module+ test (module+ test
(test-case "hash->list/ordered" (test-case "hash->list/ordered"
(check-equal? (hash->list/ordered #hash((b . 1) (a . 1))) (check-equal? (hash->list/ordered #hash((b . 1) (a . 1)))
'((a . 1) (b . 1))))) '((a . 1) (b . 1)))))
(: multi-split-at (All (a) (-> (Listof (Listof a)) Integer (: multi-split-at (All (a) (-> (Listof (Listof a)) Integer
(Values (Listof (Listof a)) (Listof (Listof a)))))) (Values (Listof (Listof a)) (Listof (Listof a))))))
(define (multi-split-at lists pos) (define (multi-split-at lists pos)
(for/fold ([lefts : (Listof (Listof a)) '()] (for/fold ([lefts : (Listof (Listof a)) '()]
[rights : (Listof (Listof a)) '()] [rights : (Listof (Listof a)) '()]
#:result (values (reverse lefts) (reverse rights))) #:result (values (reverse lefts) (reverse rights)))
@ -434,34 +423,34 @@
(define-values (left right) ((inst split-at a) lst pos)) (define-values (left right) ((inst split-at a) lst pos))
(values (cons left lefts) (cons right rights)))) (values (cons left lefts) (cons right rights))))
(module+ test (module+ test
(test-case "multi-split-at" (test-case "multi-split-at"
(define-values (l1 l2) (multi-split-at '((1 2 3) (a b c)) 2)) (define-values (l1 l2) (multi-split-at '((1 2 3) (a b c)) 2))
(check-equal? l1 '((1 2) (a b))) (check-equal? l2 '((3) (c))))) (check-equal? l1 '((1 2) (a b))) (check-equal? l2 '((3) (c)))))
;; https://racket.discourse.group/t/get-to-type-apply-in-parallel-lst/683 ;; https://racket.discourse.group/t/get-to-type-apply-in-parallel-lst/683
;; ;;
;; Same thread: (apply ((curry map) list) lsts), however I don't ;; Same thread: (apply ((curry map) list) lsts), however I don't
;; feel like typing this right now (2022-02-18). ;; feel like typing this right now (2022-02-18).
(: lists-transpose (All (a ...) (-> (List (Listof a) ... a) (Listof (List a ... a))))) (: lists-transpose (All (a ...) (-> (List (Listof a) ... a) (Listof (List a ... a)))))
(define (lists-transpose lists) (define (lists-transpose lists)
(sequence->list (in-values-sequence (apply in-parallel lists)))) (sequence->list (in-values-sequence (apply in-parallel lists))))
(module+ test (module+ test
(test-case "lists-transpose" (test-case "lists-transpose"
(check-equal? (lists-transpose '((1 2) (a b))) '((1 a) (2 b))))) (check-equal? (lists-transpose '((1 2) (a b))) '((1 a) (2 b)))))
(: in-random (case-> (: in-random (case->
(-> (Sequenceof Flonum)) (-> (Sequenceof Flonum))
(-> Integer (Sequenceof Nonnegative-Fixnum)) (-> Integer (Sequenceof Nonnegative-Fixnum))
(-> Integer Integer (Sequenceof Nonnegative-Fixnum)))) (-> Integer Integer (Sequenceof Nonnegative-Fixnum))))
(define in-random (define in-random
(case-lambda (case-lambda
[() (stream-cons (random) (in-random))] [() (stream-cons (random) (in-random))]
[(k) (stream-cons (random k) (in-random k))] [(k) (stream-cons (random k) (in-random k))]
[(min max) (stream-cons (random min max) (in-random min max))])) [(min max) (stream-cons (random min max) (in-random min max))]))
(module+ test (module+ test
(test-case "in-random" (test-case "in-random"
(random-seed 1) (random-seed 1)
(check-equal? (stream->list (stream-take (in-random 100) 10)) (check-equal? (stream->list (stream-take (in-random 100) 10))
@ -480,8 +469,8 @@
0.21646500425988832 0.21646500425988832
0.15188352823997242)))) 0.15188352823997242))))
(: cartesian-product-2/stream (All (a b) (-> (Sequenceof a) (Sequenceof b) (Sequenceof (Pair a b))))) (: cartesian-product-2/stream (All (a b) (-> (Sequenceof a) (Sequenceof b) (Sequenceof (Pair a b)))))
(define (cartesian-product-2/stream s1 s2) (define (cartesian-product-2/stream s1 s2)
(: cp2-store (All (a b) (-> (Sequenceof a) (Sequenceof b) (Sequenceof b) (: cp2-store (All (a b) (-> (Sequenceof a) (Sequenceof b) (Sequenceof b)
(Sequenceof (Pair a b))))) (Sequenceof (Pair a b)))))
;; The recursive implementation using s2-store as an accumulator. ;; The recursive implementation using s2-store as an accumulator.
@ -497,7 +486,7 @@
(cp2-store s1 (stream-rest s2) s2-store))])) (cp2-store s1 (stream-rest s2) s2-store))]))
(cp2-store s1 s2 s2)) (cp2-store s1 s2 s2))
(module+ test (module+ test
(test-case "cartesian-product-2/stream" (test-case "cartesian-product-2/stream"
(check-equal? (stream->list (cartesian-product-2/stream (in-range 1 5) '(a b))) (check-equal? (stream->list (cartesian-product-2/stream (in-range 1 5) '(a b)))
'((1 . a) (1 . b) (2 . a) (2 . b) (3 . a) (3 . b) (4 . a) (4 . b))) '((1 . a) (1 . b) (2 . a) (2 . b) (3 . a) (3 . b) (4 . a) (4 . b)))
@ -505,13 +494,13 @@
(stream->list (stream-take (cartesian-product-2/stream '(a b) (in-naturals)) 10)) (stream->list (stream-take (cartesian-product-2/stream '(a b) (in-naturals)) 10))
'((a . 0) (a . 1) (a . 2) (a . 3) (a . 4) (a . 5) (a . 6) (a . 7) (a . 8) (a . 9))))) '((a . 0) (a . 1) (a . 2) (a . 3) (a . 4) (a . 5) (a . 6) (a . 7) (a . 8) (a . 9)))))
(: cartesian-product/stream (All (a) (-> (Listof (Sequenceof a)) (Sequenceof (Listof a))))) (: cartesian-product/stream (All (a) (-> (Listof (Sequenceof a)) (Sequenceof (Listof a)))))
(define (cartesian-product/stream ss) (define (cartesian-product/stream ss)
(for/foldr ([prod (stream (list))]) (for/foldr ([prod (stream (list))])
([s (in-list ss)]) ([s (in-list ss)])
(cartesian-product-2/stream s prod))) (cartesian-product-2/stream s prod)))
(module+ test (module+ test
(test-case "cartesian-product/stream" (test-case "cartesian-product/stream"
(check-equal? (stream->list (cartesian-product/stream '())) '(())) (check-equal? (stream->list (cartesian-product/stream '())) '(()))
(check-equal? (stream->list (cartesian-product/stream '((a b c)))) (check-equal? (stream->list (cartesian-product/stream '((a b c))))
@ -530,57 +519,42 @@
(2 5 a) (2 5 a)
(2 5 b))))) (2 5 b)))))
(: boolean-power (-> Integer (Listof (Listof Boolean)))) (: boolean-power (-> Integer (Listof (Listof Boolean))))
(define (boolean-power n) (define (boolean-power n)
(apply cartesian-product (make-list n '(#f #t)))) (apply cartesian-product (make-list n '(#f #t))))
(module+ test (module+ test
(test-case "boolean-power" (test-case "boolean-power"
(check-equal? (boolean-power 2) '((#f #f) (#f #t) (#t #f) (#t #t))))) (check-equal? (boolean-power 2) '((#f #f) (#f #t) (#t #f) (#t #t)))))
(: boolean-power/stream (-> Integer (Sequenceof (Listof Boolean)))) (: boolean-power/stream (-> Integer (Sequenceof (Listof Boolean))))
(define (boolean-power/stream n) (cartesian-product/stream (make-list n '(#f #t)))) (define (boolean-power/stream n) (cartesian-product/stream (make-list n '(#f #t))))
(module+ test (module+ test
(test-case "boolean-power/stream" (test-case "boolean-power/stream"
(check-equal? (stream->list (boolean-power/stream 2)) '((#f #f) (#f #t) (#t #f) (#t #t))))) (check-equal? (stream->list (boolean-power/stream 2)) '((#f #f) (#f #t) (#t #f) (#t #t)))))
(: any->01 (-> Any (U Zero One))) (: any->01 (-> Any (U Zero One)))
(define (any->01 x) (define (any->01 x)
(if x 1 0)) (if x 1 0))
(module+ test (module+ test
(test-case "any->01" (test-case "any->01"
(check-equal? (any->01 #t) 1) (check-equal? (any->01 #t) 1)
(check-equal? (any->01 #f) 0))) (check-equal? (any->01 #f) 0)))
(: 01->boolean (-> (U Zero One) Boolean)) (: 01->boolean (-> (U Zero One) Boolean))
(define (01->boolean x) (define (01->boolean x)
(case x [(0) #f] [else #t])) (case x [(0) #f] [else #t]))
(module+ test (module+ test
(test-case "01->boolean" (test-case "01->boolean"
(check-equal? (01->boolean 0) #f) (check-equal? (01->boolean 0) #f)
(check-equal? (01->boolean 1) #t))) (check-equal? (01->boolean 1) #t)))
;; TODO: Remove when the other modules are converted to Typed Racket ;; TODO: Remove when the other modules are converted to Typed Racket
;; and these contracts are not needed any more. ;; and these contracts are not needed any more.
(: variable-mapping? (-> Any Boolean : HashTableTop)) (: variable-mapping? (-> Any Boolean : HashTableTop))
(define (variable-mapping? dict) (define (variable-mapping? dict)
(hash? dict)) (hash? dict))
)
(require 'typed)
(provide eval-with eval1-with auto-hash-ref/explicit auto-hash-ref/:
extract-symbols any->string stringify-variable-mapping string->any
map-sexp read-org-sexp unorg unstringify-pairs
read-org-variable-mapping unorgv read-symbol-list drop-first-last
list-sets->list-strings pretty-print-set pretty-print-set-sets
update-vertices/unweighted update-graph dotit collect-by-key
collect-by-key/sets ht-values/list->set hash->list/ordered
multi-split-at lists-transpose in-random cartesian-product-2/stream
cartesian-product/stream boolean-power boolean-power/stream any->01
01->boolean
variable-mapping?)