├── .gitignore ├── 2020-06-effects ├── Makefile ├── assets │ ├── BoolExp.hs │ ├── countdown │ │ ├── big-ints.csv │ │ ├── multi-module.csv │ │ └── single-module.csv │ ├── eff.png │ ├── graphql-logo.svg │ ├── hasura_logo_vertical_black.png │ ├── hasura_logo_vertical_black.svg │ ├── postgres-logo.svg │ └── proposal.png ├── lib │ ├── pict.rkt │ ├── slideshow.rkt │ └── util.rkt ├── main.rkt ├── slides-uncondensed.pdf └── slides.pdf ├── 2022-09-icfp-hiw ├── assets │ ├── hoogle-local-search-no-results.png │ ├── hoogle-search-bar.png │ └── macro-stepper.png ├── lib │ ├── color.rkt │ ├── pict.rkt │ ├── slideshow.rkt │ └── util.rkt └── main.rkt ├── 2022-11-haskell-exchange ├── assets │ ├── mercury-icon.svg │ ├── mercury-text.svg │ ├── screenshot-issue-21700-th-linking.png │ ├── screenshot-issue-21853-codegen-printer.png │ ├── screenshot-issue-bytecode-1.png │ ├── screenshot-issue-bytecode-2.png │ ├── screenshot-issue-bytecode-3.png │ ├── screenshot-mr-7502-fat-interface-files.png │ └── tweag.svg ├── lib │ ├── color.rkt │ ├── pict.rkt │ ├── slideshow.rkt │ └── util.rkt └── main.rkt ├── 2023-06-delimited-continuations ├── Makefile ├── assets │ ├── haskell-logo.svg │ └── tweag.svg ├── lib │ ├── color.rkt │ ├── pict.rkt │ ├── slideshow.rkt │ ├── unicode.rkt │ └── util.rkt ├── main.rkt ├── slides-uncondensed.pdf └── slides.pdf └── hasura ├── 2019-12-schema-cache-refactor ├── assets │ ├── incremental-pr-build.png │ ├── incremental-pr.png │ ├── timed.1.png │ ├── timed.1.svg │ ├── timed.2.png │ └── timed.2.svg └── main.rkt ├── 2020-01-arrows ├── arrows.pdf ├── assets │ ├── proposal-pr.png │ └── typechecking-rules.png └── main.rkt └── lib ├── 1.rkt └── assets ├── hasura_icon_black.svg └── postgres_logo.svg /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | *~ 3 | -------------------------------------------------------------------------------- /2020-06-effects/Makefile: -------------------------------------------------------------------------------- 1 | COMPILE := 2 | CPUS := $(shell racket -e '(display (processor-count))') 3 | RACKET_VERSION := $(shell racket -e '(display (version))') 4 | 5 | LIB_SRCS := pict.rkt slideshow.rkt util.rkt 6 | ASSET_SRCS := countdown/single-module.csv countdown/multi-module.csv 7 | 8 | ZO_PREFIX := compiled/$(RACKET_VERSION)/compiled 9 | LIB_ZOS := $(LIB_SRCS:%.rkt=lib/$(ZO_PREFIX)/%_rkt.zo) 10 | 11 | SLIDESHOW_OPTS := --pdf --not-paper --widescreen --zero-margins --no-stretch \ 12 | --no-resize --progress-text 13 | 14 | SLIDES_DEPS := main.rkt $(addprefix assets/,$(ASSET_SRCS)) 15 | ifdef COMPILE 16 | SLIDES_DEPS += compile 17 | else 18 | SLIDES_DEPS += $(LIB_ZOS) 19 | endif 20 | 21 | slides.pdf: $(SLIDES_DEPS) 22 | slideshow $(SLIDESHOW_OPTS) --condense -o slides.pdf main.rkt 23 | slides-uncondensed.pdf: $(SLIDES_DEPS) 24 | slideshow $(SLIDESHOW_OPTS) -o slides-uncondensed.pdf main.rkt 25 | 26 | lib/$(ZO_PREFIX)/slideshow_rkt.zo: lib/$(ZO_PREFIX)/pict_rkt.zo lib/$(ZO_PREFIX)/util_rkt.zo 27 | 28 | %_rkt.zo: ../../../%.rkt 29 | raco make $< 30 | 31 | all: slides.pdf slides-uncondensed.pdf 32 | 33 | compile: main.rkt $(addprefix lib/,$(LIB_SRCS)) 34 | raco make -v -j '$(CPUS)' main.rkt 35 | 36 | watch: 37 | @watch-exec --bell -p main.rkt $(addprefix -p lib/,$(LIB_SRCS)) -- \ 38 | '$(MAKE)' -j '$(CPUS)' CPUS='$(CPUS)' RACKET_VERSION='$(RACKET_VERSION)' 39 | 40 | .PHONY: all compile watch 41 | -------------------------------------------------------------------------------- /2020-06-effects/assets/BoolExp.hs: -------------------------------------------------------------------------------- 1 | parseAsSTDWithinObj obj = do 2 | distanceVal <- onNothing (OMap.lookup "distance" obj) $ 3 | throw500 "expected \"distance\" input field in st_d_within" 4 | dist <- mkParameterizablePGValue <$> asPGColumnValue distanceVal 5 | fromVal <- onNothing (OMap.lookup "from" obj) $ 6 | throw500 "expected \"from\" input field in st_d_within" 7 | from <- mkParameterizablePGValue <$> asPGColumnValue fromVal 8 | PGColumnScalar PGGeography -> do 9 | onNothing (OMap.lookup "use_spheroid" obj) $ 10 | throw500 "expected \"use_spheroid\" input field in st_d_within" 11 | return $ ASTDWithinGeog $ DWithinGeogOp dist from useSpheroid 12 | PGColumnScalar PGGeometry -> 13 | return $ ASTDWithinGeom $ DWithinGeomOp dist from 14 | _ -> throw500 "expected PGGeometry/PGGeography column for st_d_within" 15 | parseAsSTIntersectsNbandGeomObj obj = do 16 | nbandVal <- onNothing (OMap.lookup "nband" obj) $ 17 | throw500 "expected \"nband\" input field" 18 | nband <- mkParameterizablePGValue <$> asPGColumnValue nbandVal 19 | geommin <- parseGeommin obj 20 | return $ ASTIntersectsNbandGeom $ STIntersectsNbandGeommin nband geommin 21 | parseAsSTIntersectsGeomNbandObj obj = do 22 | nbandMM <- fmap (fmap mkParameterizablePGValue) <$> 23 | traverse asPGColumnValueM (OMap.lookup "nband" obj) 24 | geommin <- parseGeommin obj 25 | parseGeommin obj = do 26 | geomminVal <- onNothing (OMap.lookup "geommin" obj) $ 27 | throw500 "expected \"geommin\" input field" 28 | mkParameterizablePGValue <$> asPGColumnValue geomminVal 29 | -------------------------------------------------------------------------------- /2020-06-effects/assets/countdown/big-ints.csv: -------------------------------------------------------------------------------- 1 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 2 | baseline,8.711781918033278e-6,8.60564666991416e-6,8.891461965477956e-6,4.545113400621381e-7,3.201862127712541e-7,7.083971681519196e-7 3 | eff,2.4200542033701237e-5,2.3939100537127596e-5,2.4524651307033328e-5,9.417949207096138e-7,7.822332660779093e-7,1.2325083967654501e-6 4 | -------------------------------------------------------------------------------- /2020-06-effects/assets/countdown/multi-module.csv: -------------------------------------------------------------------------------- 1 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 2 | baseline,1.234871499295562e-6,1.226849128755168e-6,1.25679572145746e-6,3.8345561857819436e-8,1.8877102783571757e-8,7.484769319204756e-8 3 | eff,1.2515224922677208e-5,1.245539189642789e-5,1.2593830600429735e-5,2.221468449395791e-7,1.6923832465459353e-7,3.152263205741282e-7 4 | mtl,6.39633015212113e-5,6.336930413373704e-5,6.5641509666337e-5,2.9480277176918684e-6,1.265797687405677e-6,5.9638609915246304e-6 5 | fused-effects,1.162132158615809e-4,1.1534987683429527e-4,1.1834003906002367e-4,4.380521340869371e-6,1.997256756246151e-6,8.387112987087759e-6 6 | polysemy,2.765824310971395e-4,2.730682035616084e-4,2.914632736444163e-4,1.9135348471104195e-5,7.409810166664536e-6,4.052263761522204e-5 7 | -------------------------------------------------------------------------------- /2020-06-effects/assets/countdown/single-module.csv: -------------------------------------------------------------------------------- 1 | Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB 2 | baseline,1.1872967013869111e-6,1.1705080905728886e-6,1.206063635740959e-6,6.346057566571064e-8,5.536160094712818e-8,7.774510346167939e-8 3 | eff,1.2798176486509192e-5,1.2660849444911472e-5,1.3079908993437922e-5,5.958840989772167e-7,3.7423333667037545e-7,9.991752909955488e-7 4 | mtl,1.1663895839083784e-6,1.1561251513870599e-6,1.1774800706942456e-6,3.7691054857097294e-8,3.196479013586212e-8,4.763148979182893e-8 5 | fused-effects,1.206574051101826e-6,1.1938019659886701e-6,1.2203759382439482e-6,4.365280299380722e-8,3.480218962241111e-8,5.954233066500473e-8 6 | polysemy,2.4451282509958247e-4,2.4194572390766344e-4,2.475811214480574e-4,9.581200640451055e-6,7.0344395823908606e-6,1.2746639472321234e-5 7 | -------------------------------------------------------------------------------- /2020-06-effects/assets/eff.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2020-06-effects/assets/eff.png -------------------------------------------------------------------------------- /2020-06-effects/assets/graphql-logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 72 | -------------------------------------------------------------------------------- /2020-06-effects/assets/hasura_logo_vertical_black.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2020-06-effects/assets/hasura_logo_vertical_black.png -------------------------------------------------------------------------------- /2020-06-effects/assets/hasura_logo_vertical_black.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 6 | 7 | 12 | 16 | 17 | 18 | 22 | 25 | 29 | 31 | 35 | 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /2020-06-effects/assets/postgres-logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /2020-06-effects/assets/proposal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2020-06-effects/assets/proposal.png -------------------------------------------------------------------------------- /2020-06-effects/lib/pict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require pict 4 | pict/conditional 5 | ppict/align 6 | racket/class 7 | racket/contract 8 | racket/draw 9 | racket/match 10 | slideshow/base 11 | threading) 12 | 13 | (provide (contract-out [pict-color/c flat-contract?] 14 | [pict-finder/c chaperone-contract?] 15 | [ppath-cons (-> pict? (or/c pict-path? #f) pict-path?)] 16 | [adjust-find (-> pict-finder/c real? real? pict-finder/c)] 17 | 18 | [pict-when (-> any/c pict? pict?)] 19 | [pict-unless (-> any/c pict? pict?)] 20 | [picts-take (-> (listof pict?) exact-nonnegative-integer? (listof pict?))] 21 | 22 | [current-highlight-color (parameter/c pict-color/c)] 23 | 24 | [line (-> real? real? pict?)] 25 | [arrow-line (->* [] [#:arrow-size real? 26 | #:line-length real? 27 | #:line-width real?] 28 | pict?)] 29 | [highlight (->* [pict?] [#:bleed real? #:color pict-color/c] pict?)] 30 | [highlight-if (->* [any/c pict?] [#:bleed real? #:color pict-color/c] pict?)] 31 | [file-icon (-> real? real? pict?)] 32 | 33 | [em (->* [] [real?] real?)] 34 | [one-line (-> pict? pict?)] 35 | [indent (->* [pict?] [#:by real?] pict?)] 36 | 37 | [maybe-colorize (-> pict? (or/c pict-color/c #f) pict?)] 38 | [set-smoothing (-> pict? (or/c 'unsmoothed 'smoothed 'aligned) pict?)] 39 | [adjust-pen (->* [pict?] 40 | [#:color (or/c string? (is-a?/c color%) #f) 41 | #:width (or/c (real-in 0 255) #f) 42 | #:style (or/c pen-style/c #f) 43 | #:cap (or/c pen-cap-style/c #f) 44 | #:join (or/c pen-join-style/c #f)] 45 | pict?)] 46 | [cellophane (-> pict? (real-in 0 1) pict?)] 47 | [metrics-frame (-> pict? pict?)] 48 | [pip (case-> (-> pict? pict-finder/c pict?) 49 | (-> pict? 50 | (or/c real? pict-path?) 51 | (or/c real? pict-finder/c) 52 | pict?))] 53 | [rsvg-isolate (-> pict? pict?)] 54 | 55 | [line-append (-> pict? pict? ... pict?)] 56 | (struct spring ([weight real?])) 57 | [hflex (->* [real?] 58 | [#:combine (-> pict? pict? ... pict?)] 59 | #:rest (non-empty-listof (or/c pict? spring?)) 60 | pict?)])) 61 | 62 | ;; ----------------------------------------------------------------------------- 63 | ;; miscellany 64 | 65 | (define pict-color/c (or/c string? (is-a?/c color%) (list/c byte? byte? byte?))) 66 | (define pict-finder/c (-> pict? pict-path? (values real? real?))) 67 | 68 | (define (ppath-cons p path) 69 | (match path 70 | [#f p] 71 | [(? list?) (cons p path)] 72 | [(? pict?) (list p path)])) 73 | 74 | (define (ppath-last path) 75 | (match path 76 | [#f #f] 77 | [(list _ ... p) p] 78 | [(? pict? p) p])) 79 | 80 | (define ((adjust-find find dx dy) p path) 81 | (define-values [x y] (find p path)) 82 | (values (+ x dx) (+ y dy))) 83 | 84 | ;; ----------------------------------------------------------------------------- 85 | ;; conditionals 86 | 87 | (define (pict-when test then) 88 | (if test then (ghost then))) 89 | (define (pict-unless test then) 90 | (if test (ghost then) then)) 91 | 92 | (define (picts-take ps n) 93 | (for/list ([p (in-list ps)] 94 | [i (in-naturals)]) 95 | (if (< i n) p (ghost p)))) 96 | 97 | ;; ----------------------------------------------------------------------------- 98 | ;; parameters 99 | 100 | (define current-highlight-color (make-parameter (make-color #xFF #xB9 #xB5))) 101 | 102 | ;; ----------------------------------------------------------------------------- 103 | ;; constructors 104 | 105 | (define (line dx dy) 106 | (dc (λ (dc x y) (send dc draw-line x y (+ x dx) (+ y dy))) dx dy)) 107 | 108 | (define (arrow-line #:arrow-size [arrow-size 10] 109 | #:line-length [line-length 70] 110 | #:line-width [line-width 2]) 111 | (panorama (pin-over/align (linewidth line-width (hline line-length line-width)) 112 | line-length (/ line-width 2) 'c 'c 113 | (arrowhead arrow-size 0)))) 114 | 115 | (define (highlight p #:bleed [bleed 6] #:color [color (current-highlight-color)]) 116 | (define bg (filled-rectangle (+ (pict-width p) (* 2 bleed)) 117 | (+ (- (pict-height p) (pict-descent p)) (* 2 bleed)) 118 | #:draw-border? #f 119 | #:color color)) 120 | (refocus (cc-superimpose bg p) p)) 121 | (define (highlight-if c p #:bleed [bleed 6] #:color [color (current-highlight-color)]) 122 | (pict-if c (highlight p #:bleed bleed #:color color) p)) 123 | 124 | ; Adapted from pict. 125 | (define (file-icon w h) 126 | (dc (let* ([sw (lambda (x) (* (/ w 110) x))] 127 | [sh (lambda (y) (* (/ h 150) y))] 128 | [->pt (lambda (l) 129 | (map (lambda (p) 130 | (make-object point% 131 | (sw (car p)) 132 | (sh (cadr p)))) 133 | l))]) 134 | (lambda (dc x y) 135 | (send dc draw-polygon 136 | (->pt '((0 0) 137 | (0 150) 138 | (110 150) 139 | (110 20) 140 | (90 0))) 141 | x y) 142 | (send dc draw-line (+ x (sw 90)) (+ y 1) (+ x (sw 90)) (+ y (sh 20))) 143 | (send dc draw-line (+ x (sw 90)) (+ y (sh 20)) (+ x (sw 110) -1) (+ y (sh 20))))) 144 | w h)) 145 | 146 | ;; ----------------------------------------------------------------------------- 147 | ;; sizing / bounding box adjusters 148 | 149 | (define (em [n 1]) (* (pict-width (t "M")) n)) 150 | 151 | ; Drops the ascent line to the descent line, making the entire pict behave as a 152 | ; single line of text. 153 | (define (one-line p) 154 | (define ascent (- (pict-height p) (pict-descent p))) 155 | (pin-over (blank (pict-width p) (pict-height p) ascent (pict-descent p)) 0 0 p)) 156 | 157 | (define (indent #:by [n (em)] p) (inset p n 0 0 0)) 158 | 159 | ;; ----------------------------------------------------------------------------- 160 | ;; drawing adjusters 161 | 162 | (define (maybe-colorize p color) 163 | (if color (colorize p color) p)) 164 | 165 | (define (dc/wrap p proc) 166 | (define draw-p (make-pict-drawer p)) 167 | (struct-copy 168 | pict 169 | (dc (λ (dc dx dy) (proc draw-p dc dx dy)) 170 | (pict-width p) 171 | (pict-height p) 172 | (pict-ascent p) 173 | (pict-descent p)) 174 | [children (list (make-child p 0 0 1 1 0 0))] 175 | [last (pict-last p)])) 176 | 177 | (define (set-smoothing p smoothing) 178 | (define draw-p (make-pict-drawer p)) 179 | (struct-copy 180 | pict 181 | (dc (λ (dc dx dy) 182 | (define old-smoothing (send dc get-smoothing)) 183 | (send dc set-smoothing smoothing) 184 | (draw-p dc dx dy) 185 | (send dc set-smoothing old-smoothing)) 186 | (pict-width p) 187 | (pict-height p) 188 | (pict-ascent p) 189 | (pict-descent p)) 190 | [children (list (make-child p 0 0 1 1 0 0))] 191 | [last (pict-last p)])) 192 | 193 | (define (set-pen #:color [color (make-color 0 0 0)] 194 | #:width [width 0] 195 | #:style [style 'solid] 196 | #:cap [cap 'round] 197 | #:join [join 'round] 198 | p) 199 | (dc/wrap p (λ (draw-p dc dx dy) 200 | (define old-pen (send dc get-pen)) 201 | (send dc set-pen (make-pen #:color color 202 | #:width width 203 | #:style style 204 | #:cap cap 205 | #:join join)) 206 | (draw-p dc dx dy) 207 | (send dc set-pen old-pen)))) 208 | 209 | (define (adjust-pen #:color [color #f] 210 | #:width [width #f] 211 | #:style [style #f] 212 | #:cap [cap #f] 213 | #:join [join #f] 214 | p) 215 | (define draw-p (make-pict-drawer p)) 216 | (struct-copy 217 | pict 218 | (dc (λ (dc dx dy) 219 | (define old-pen (send dc get-pen)) 220 | (send dc set-pen (make-pen #:color (or color (send old-pen get-color)) 221 | #:width (or width (send old-pen get-width)) 222 | #:style (or style (send old-pen get-style)) 223 | #:cap (or cap (send old-pen get-cap)) 224 | #:join (or join (send old-pen get-join)) 225 | #:stipple (send old-pen get-stipple))) 226 | (draw-p dc dx dy) 227 | (send dc set-pen old-pen)) 228 | (pict-width p) 229 | (pict-height p) 230 | (pict-ascent p) 231 | (pict-descent p)) 232 | [children (list (make-child p 0 0 1 1 0 0))] 233 | [last (pict-last p)])) 234 | 235 | ; Like cellophane from pict, but blends the entire pict as a single group. 236 | (define (cellophane p opacity) 237 | (dc/wrap p (λ (draw-p dc dx dy) 238 | (define old-alpha (send dc get-alpha)) 239 | (send dc set-alpha 1) 240 | (send dc push-group) 241 | (draw-p dc dx dy) 242 | (send dc set-alpha (* old-alpha opacity)) 243 | (send dc draw-group) 244 | (send dc set-alpha old-alpha)))) 245 | 246 | ; For debugging: add bounding box lines to the given pict. 247 | (define (metrics-frame p) 248 | (define metrics-line (hline (pict-width p) 0)) 249 | (define a (pict-ascent p)) 250 | (define b (- (pict-height p) (pict-descent p))) 251 | (define metrics (~> (rectangle (pict-width p) (pict-height p)) 252 | (pin-over 0 a (adjust-pen metrics-line #:color "red")) 253 | (pin-over 0 b (adjust-pen metrics-line #:color "blue" 254 | #:style (if (< (abs (- a b)) 0.0001) 255 | 'long-dash 256 | 'solid))) 257 | (set-pen))) 258 | (pin-over p 0 0 metrics)) 259 | 260 | ; Convert the pict to a zero-sized pict centered at a particular location. 261 | (define pip 262 | (case-lambda 263 | [(p find) 264 | (pip p p find)] 265 | [(p a b) 266 | (define pinhole (blank)) 267 | (refocus (pin-over p a b pinhole) pinhole)])) 268 | 269 | (define (rsvg-isolate p) 270 | (define draw-p (make-pict-drawer p)) 271 | (dc (λ (dc x y) 272 | ; for reasons I cannot fathom, this prevents rsvg from screwing up the 273 | ; color of subsequent draw operations 274 | (define old-pen (send dc get-pen)) 275 | (send dc set-pen (make-pen #:style 'transparent)) 276 | (send dc draw-point -inf.0 -inf.0) 277 | (send dc set-pen old-pen) 278 | (draw-p dc x y)) 279 | (pict-width p) 280 | (pict-height p) 281 | (pict-ascent p) 282 | (pict-descent p))) 283 | 284 | ;; ----------------------------------------------------------------------------- 285 | ;; combiners 286 | 287 | ; Combines picts by extending the last line, as determined by pict-last. 288 | (define (line-append p0 . ps) 289 | (foldl (λ (p2 p1) (line-append/2 p1 p2)) p0 ps)) 290 | (define (line-append/2 p1 p2) 291 | (define draw-p1 (make-pict-drawer p1)) 292 | (define draw-p2 (make-pict-drawer p2)) 293 | ; find the rightmost point on the baseline of (pict-last p1) 294 | (define-values [last-x last-y] (rbl-find p1 (or (pict-last p1) p1))) 295 | 296 | ; figure out where we’ll place p2 relative to p1, since we want to align the 297 | ; descent line of (pict-last p1) with the ascent line of p2 298 | (define p2-y-relative (- last-y (pict-ascent p2))) 299 | ; if p2-y is negative, that means p2’s ascent peeks out above the top of p1, 300 | ; so compute how far we need to offset p1/p2 relative to the top of the new pict 301 | (define p1-y (if (negative? p2-y-relative) (- p2-y-relative) 0)) 302 | (define p2-y (if (negative? p2-y-relative) 0 p2-y-relative)) 303 | 304 | ; the x coordinate is simpler, since we don’t have to deal with ascent/descent, 305 | ; but it’s possible (though unlikely) that last-x is negative, in which case we 306 | ; want to do a similar adjustment 307 | (define p1-x (if (negative? last-x) (- last-x) 0)) 308 | (define p2-x (if (negative? last-x) 0 last-x)) 309 | 310 | ; compute rightmost point and bottommost point in the new pict’s bounding box 311 | (define w (max (+ p1-x (pict-width p1)) 312 | (+ p2-x (pict-width p2)))) 313 | (define h (max (+ p1-y (pict-height p1)) 314 | (+ p2-y (pict-height p2)))) 315 | ; same for uppermost ascent line and lowermost descent line 316 | (define a (min (+ p1-y (pict-ascent p1)) 317 | (+ p2-y (pict-ascent p2)))) 318 | (define d (- h (max (+ p1-y (- (pict-height p1) (pict-descent p1))) 319 | (+ p2-y (- (pict-height p2) (pict-descent p2)))))) 320 | 321 | ; compute child offsets, which are weird because pict uses an inverted 322 | ; coordinate system, so these are relative to the lowermost point 323 | (define p1-dy (- h (+ p1-y (pict-height p1)))) 324 | (define p2-dy (- h (+ p2-y (pict-height p2)))) 325 | 326 | ; invent a new, totally unique pict to use as pict-last, in case (pict-last p2) 327 | ; already exists somewhere in the pict 328 | (define p2-last (or (ppath-last (pict-last p2)) p2)) 329 | (define-values [p2-last-x p2-last-y] (lt-find p2 (or (pict-last p2) p2))) 330 | (define last-p (blank (pict-width p2-last) 331 | (pict-height p2-last) 332 | (pict-ascent p2-last) 333 | (pict-descent p2-last))) 334 | 335 | (~> (dc (λ (dc dx dy) 336 | (draw-p1 dc (+ dx p1-x) (+ dy p1-y)) 337 | (draw-p2 dc (+ dx p2-x) (+ dy p2-y))) 338 | w h a d) 339 | (struct-copy pict _ 340 | [children (list (make-child p1 p1-x p1-dy 1 1 0 0) 341 | (make-child p2 p2-x p2-dy 1 1 0 0) 342 | (make-child last-p 343 | (+ p2-x p2-last-x) 344 | (+ p2-dy p2-last-y) 345 | 1 1 0 0))] 346 | [last last-p]))) 347 | 348 | (struct spring (weight) #:transparent) 349 | (define (hflex width #:combine [combine hc-append] . elements) 350 | (define fixed-width (for/sum ([e (in-list elements)] #:unless (spring? e)) (pict-width e))) 351 | (define flexi-width (- width fixed-width)) 352 | (define total-weight (for/sum ([e (in-list elements)] #:when (spring? e)) (spring-weight e))) 353 | (define width-per-weight (/ flexi-width total-weight)) 354 | (apply combine (for/list ([element (in-list elements)]) 355 | (match element 356 | [(spring weight) (blank (* weight width-per-weight) 0)] 357 | [_ element])))) 358 | -------------------------------------------------------------------------------- /2020-06-effects/lib/slideshow.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (except-in pict cellophane file-icon) 4 | racket/contract 5 | racket/match 6 | slideshow/base 7 | slideshow/code 8 | slideshow/text 9 | threading 10 | 11 | (prefix-in slideshow: slideshow/base) 12 | 13 | "pict.rkt" 14 | "util.rkt") 15 | 16 | (provide (contract-out [current-slide-margin (parameter/c real?)] 17 | [make-scaling-slide-assembler (->* [] [#:background-color pict-color/c] 18 | (-> (or/c string? #f) 19 | exact-nonnegative-integer? 20 | pict? 21 | pict?))] 22 | 23 | [current-text-color (parameter/c (or/c pict-color/c #f))] 24 | [tt (-> string? pict?)] 25 | 26 | [para-spacing/c flat-contract?] 27 | [para-align/c flat-contract?] 28 | [current-para-spacing (parameter/c para-spacing/c)] 29 | [current-para-align (parameter/c para-align/c)] 30 | [current-para-fill? (parameter/c any/c)] 31 | [current-item-indent (parameter/c (or/c real? (-> real?)) real?)] 32 | [para (->* [] [#:width real? 33 | #:align para-align/c 34 | #:spacing para-spacing/c 35 | #:fill? any/c 36 | #:decode? any/c 37 | #:color (or/c pict-color/c #f)] 38 | #:rest (listof para-element/c) 39 | pict?)] 40 | [elem (->* [] [#:decode? any/c 41 | #:color (or/c pict-color/c #f)] 42 | #:rest (listof para-element/c) 43 | pict?)] 44 | [item (->* [] [#:width real? 45 | #:align para-align/c 46 | #:fill? any/c 47 | #:decode? any/c 48 | #:color (or/c pict-color/c #f)] 49 | #:rest (listof para-element/c) 50 | pict?)] 51 | [resolve-para-spacing (->* [] [para-spacing/c] real?)] 52 | [paras (->* [] [#:align para-align/c 53 | #:spacing para-spacing/c 54 | #:stage (or/c exact-integer? #f)] 55 | #:rest (listof pict?) 56 | pict?)])) 57 | 58 | ;; ----------------------------------------------------------------------------- 59 | ;; slide assembler 60 | 61 | (define current-slide-margin (make-parameter 20)) 62 | 63 | (define ((make-scaling-slide-assembler #:background-color [background-color "white"]) 64 | title-str gap content) 65 | (define background 66 | (inset (filled-rectangle (+ client-w (* margin 2)) 67 | (+ client-h (* margin 2)) 68 | #:draw-border? #f 69 | #:color background-color) 70 | (- margin))) 71 | (define title (and title-str (~> ((current-titlet) title-str) 72 | (scale-to-fit client-w title-h)))) 73 | (define content-area 74 | (~> (if title 75 | (blank (pict-width background) 76 | (- (pict-height background) 77 | (pict-height title) 78 | gap)) 79 | (ghost background)) 80 | (inset (- (current-slide-margin))))) 81 | (define bounded-content (scale-to-fit content content-area #:mode 'inset)) 82 | (define title+content (if title (vc-append gap title bounded-content) bounded-content)) 83 | (cc-superimpose background title+content)) 84 | 85 | ;; ----------------------------------------------------------------------------- 86 | ;; text and layout 87 | 88 | (define current-text-color (make-parameter #f)) 89 | 90 | (define (tt s) 91 | (with-font (current-code-font) 92 | (with-size ((get-current-code-font-size)) (t s)))) 93 | 94 | (define para-spacing/c (or/c real? (list/c 'lines real?))) 95 | (define para-align/c (or/c 'left 'center 'right)) 96 | (define para-element/c (flat-rec-contract elem/c 97 | (or/c string? pict? (listof elem/c)))) 98 | 99 | (define current-para-spacing (make-parameter '(lines 0.2))) 100 | (define current-para-align (make-parameter 'left)) 101 | (define current-para-fill? (make-parameter #t (λ (v) (and v #t)))) 102 | (define current-item-indent (make-lazy-parameter em)) 103 | 104 | (define (para #:width [width (current-para-width)] 105 | #:align [align (current-para-align)] 106 | #:spacing [spacing (current-line-sep)] 107 | #:fill? [fill? (current-para-fill?)] 108 | #:decode? [decode? #t] 109 | #:color [color (current-text-color)] 110 | . elements) 111 | (parameterize ([current-line-sep (resolve-para-spacing spacing)]) 112 | (~> (apply slideshow:para #:width width #:align align #:fill? fill? #:decode? decode? elements) 113 | (maybe-colorize color)))) 114 | 115 | (define (elem #:decode? [decode? #t] 116 | #:color [color (current-text-color)] 117 | . elements) 118 | (apply para #:width +inf.0 #:fill? #f #:decode? decode? #:color color elements)) 119 | 120 | (define (item #:width [width (current-para-width)] 121 | #:align [align (current-para-align)] 122 | #:indent [indent (current-item-indent)] 123 | #:fill? [fill? (current-para-fill?)] 124 | #:decode? [decode? #t] 125 | #:color [color (current-text-color)] 126 | . elements) 127 | (define bullet (htl-append (blank indent 0) (elem "→") (blank (em 0.75) 0))) 128 | (htl-append bullet 129 | (apply para #:width (- width (pict-width bullet)) 130 | #:align align #:fill? fill? #:decode? decode? elements))) 131 | 132 | (define (resolve-para-spacing [spacing (current-para-spacing)]) 133 | (match spacing 134 | [(? real?) spacing] 135 | [(list 'lines n) (* (current-font-size) n)])) 136 | 137 | (define (paras #:align [align (current-para-align)] 138 | #:spacing [spacing (current-para-spacing)] 139 | #:stage [stage #f] 140 | . elements) 141 | (apply (match align 142 | ['left vl-append] 143 | ['center vc-append] 144 | ['right vr-append]) 145 | (resolve-para-spacing spacing) 146 | (for/list ([element (in-list elements)] 147 | [i (in-naturals)]) 148 | (pict-when (or (not stage) (< i stage)) element)))) 149 | -------------------------------------------------------------------------------- /2020-06-effects/lib/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | racket/function 5 | racket/math 6 | syntax/parse/define 7 | threading) 8 | 9 | (provide when~> 10 | (contract-out [make-lazy-parameter (-> any/c parameter?)] 11 | [turns (-> real? real?)])) 12 | 13 | (define (make-lazy-parameter val) 14 | (make-derived-parameter (make-parameter val) 15 | identity 16 | (λ (v) (if (procedure? v) (v) v)))) 17 | 18 | (define-simple-macro (when~> e:expr c:expr s:expr ...) 19 | (let ([v e]) (if c (~> v s ...) v))) 20 | 21 | (define (turns n) (* 2 pi n)) 22 | -------------------------------------------------------------------------------- /2020-06-effects/slides-uncondensed.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2020-06-effects/slides-uncondensed.pdf -------------------------------------------------------------------------------- /2020-06-effects/slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2020-06-effects/slides.pdf -------------------------------------------------------------------------------- /2022-09-icfp-hiw/assets/hoogle-local-search-no-results.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2022-09-icfp-hiw/assets/hoogle-local-search-no-results.png -------------------------------------------------------------------------------- /2022-09-icfp-hiw/assets/hoogle-search-bar.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2022-09-icfp-hiw/assets/hoogle-search-bar.png -------------------------------------------------------------------------------- /2022-09-icfp-hiw/assets/macro-stepper.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2022-09-icfp-hiw/assets/macro-stepper.png -------------------------------------------------------------------------------- /2022-09-icfp-hiw/lib/color.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/struct-info) 5 | racket/class 6 | racket/contract 7 | racket/draw 8 | racket/match 9 | threading) 10 | 11 | (provide (rename-out [rgb* rgb] [hsv* hsv]) 12 | rgb-red rgb-green rgb-blue rgb-alpha 13 | hsv-hue hsv-saturation hsv-value hsv-alpha 14 | 15 | (contract-out 16 | [color? predicate/c] 17 | [->color% (-> color? (is-a?/c color%))] 18 | [->rgb (-> color? rgb?)] 19 | [->hsv (-> color? hsv?)] 20 | 21 | [scale-color-value (-> color? (>=/c 0) color?)] 22 | [add-color-value (-> color? real? color?)])) 23 | 24 | ;; ----------------------------------------------------------------------------- 25 | 26 | (define (fmod x n) 27 | (define i (floor x)) 28 | (+ (remainder i n) (- x i))) 29 | 30 | (struct rgb (red green blue alpha) #:transparent 31 | #:guard (struct-guard/c (real-in 0 1) (real-in 0 1) (real-in 0 1) (real-in 0 1))) 32 | (struct hsv (hue saturation value alpha) #:transparent 33 | #:guard (struct-guard/c (real-in 0 1) (real-in 0 1) (real-in 0 1) (real-in 0 1))) 34 | 35 | (define (make-rgb r g b [alpha 1.0]) 36 | (rgb r g b alpha)) 37 | (define (make-hsv h s v [alpha 1.0]) 38 | (define h* (- h (truncate h))) 39 | (hsv (if (< h* 0.0) (+ 1.0 h*) h*) s v alpha)) 40 | 41 | (begin-for-syntax 42 | (struct struct-info (ctor-id list field-syms) #:transparent 43 | #:property prop:struct-info (λ (self) (struct-info-list self)) 44 | #:property prop:struct-field-info (λ (self) (struct-info-field-syms self)) 45 | #:property prop:expansion-contexts '(expression) 46 | #:property prop:procedure 47 | (λ (self stx) 48 | (define ctor-id (struct-info-ctor-id self)) 49 | (syntax-case stx () 50 | [id (identifier? #'id) ctor-id] 51 | [(_ . args) (datum->syntax stx (cons ctor-id #'args) stx)]))) 52 | (define (make-custom-ctor-struct-info base-id ctor-id) 53 | (define base-info (syntax-local-value base-id)) 54 | (define base-list (extract-struct-info base-info)) 55 | (define base-fields (struct-field-info-list base-info)) 56 | (struct-info ctor-id 57 | (list* (car base-list) ctor-id (cddr base-list)) 58 | base-fields))) 59 | 60 | (define-syntax rgb* (make-custom-ctor-struct-info #'rgb #'make-rgb)) 61 | (define-syntax hsv* (make-custom-ctor-struct-info #'hsv #'make-hsv)) 62 | 63 | (define (hsv->rgb h s v [alpha 1.0]) 64 | (define (f n) 65 | (define k (fmod (+ n (* h 6.0)) 6)) 66 | (- v (* v s (max 0.0 (min k (- 4.0 k) 1.0))))) 67 | (rgb (f 5.0) (f 3.0) (f 1.0) alpha)) 68 | 69 | (define (rgb->hsv r g b [alpha 1.0]) 70 | (define v (max r g b)) 71 | (define chroma (- v (min r g b))) 72 | (define h (cond 73 | [(zero? chroma) 0.0] 74 | [(= v r) (/ (/ (- g b) chroma) 6.0)] 75 | [(= v g) (/ (+ 2.0 (/ (- b r) chroma)) 6.0)] 76 | [else (/ (+ 4.0 (/ (- r g) chroma)) 6.0)])) 77 | (define s (if (zero? chroma) 0 (/ chroma v))) 78 | (hsv h s v alpha)) 79 | 80 | ;; ----------------------------------------------------------------------------- 81 | 82 | (define (color? v) 83 | (or (is-a? v color%) 84 | (rgb? v) 85 | (hsv? v) 86 | (and (string? v) 87 | (send the-color-database find-color v) 88 | #t))) 89 | 90 | (define (find-color% who name) 91 | (or (send the-color-database find-color name) 92 | (raise-arguments-error who "no known color with name" "name" name))) 93 | 94 | (define (->color% v) 95 | (match v 96 | [(? (λ~> (is-a? color%))) v] 97 | [(rgb r g b a) 98 | (define (f n) (inexact->exact (round (max 0 (min (* n 255) 255))))) 99 | (make-color (f r) (f g) (f b) a)] 100 | [(hsv h s v a) 101 | (->color% (hsv->rgb h s v a))] 102 | [(? string?) 103 | (find-color% '->color% v)])) 104 | 105 | (define (->rgb v) 106 | (match v 107 | [(? rgb?) v] 108 | [(? (λ~> (is-a? color%))) 109 | (rgb (/ (send v red) 255.0) 110 | (/ (send v green) 255.0) 111 | (/ (send v blue) 255.0) 112 | (send v alpha))] 113 | [(hsv h s v a) 114 | (hsv->rgb h s v a)] 115 | [(? string?) 116 | (->rgb (find-color% '->rgb v))])) 117 | 118 | (define (->hsv v) 119 | (match v 120 | [(? hsv?) v] 121 | [(? (λ~> (is-a? color%))) 122 | (rgb->hsv (/ (send v red) 255.0) 123 | (/ (send v green) 255.0) 124 | (/ (send v blue) 255.0) 125 | (send v alpha))] 126 | [(rgb r g b a) 127 | (rgb->hsv r g b a)] 128 | [(? string?) 129 | (->hsv (find-color% '->hsv v))])) 130 | 131 | ;; ----------------------------------------------------------------------------- 132 | 133 | (define (scale-color-value color fac) 134 | (match-define (hsv h s v a) (->hsv color)) 135 | (hsv h s (min (* v fac) 1) a)) 136 | 137 | (define (add-color-value color amt) 138 | (match-define (hsv h s v a) (->hsv color)) 139 | (hsv h s (max 0 (min (+ v amt) 1)) a)) 140 | -------------------------------------------------------------------------------- /2022-09-icfp-hiw/lib/pict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require pict 4 | pict/conditional 5 | ppict/align 6 | ppict/tag 7 | racket/class 8 | racket/contract 9 | racket/draw 10 | racket/match 11 | slideshow/base 12 | threading 13 | "color.rkt" 14 | "util.rkt") 15 | 16 | (provide (contract-out [pict-color/c flat-contract?] 17 | [pict-finder/c chaperone-contract?] 18 | [ppath-cons (-> pict? (or/c pict-path? #f) pict-path?)] 19 | [adjust-find (-> pict-finder/c real? real? pict-finder/c)] 20 | 21 | [pict-when (-> any/c pict? pict?)] 22 | [pict-unless (-> any/c pict? pict?)] 23 | [picts-take (-> (listof pict?) exact-nonnegative-integer? (listof pict?))] 24 | 25 | [current-highlight-color (parameter/c pict-color/c)] 26 | [current-highlight-border-color (lazy-parameter/c pict-color/c)] 27 | 28 | [line (-> real? real? pict?)] 29 | [arrow-line (->* [] [#:arrow-size real? 30 | #:line-length real? 31 | #:line-width real?] 32 | pict?)] 33 | [highlight (->* [pict?] [#:bleed real? #:color pict-color/c] pict?)] 34 | [highlight-if (->* [any/c pict?] [#:bleed real? #:color pict-color/c] pict?)] 35 | [file-icon (-> real? real? pict?)] 36 | 37 | [em (->* [] [real?] real?)] 38 | [one-line (-> pict? pict?)] 39 | [indent (->* [pict?] [#:by real?] pict?)] 40 | [pip (case-> (-> pict? pict-finder/c pict?) 41 | (-> pict? 42 | (or/c real? pict-path?) 43 | (or/c real? pict-finder/c) 44 | pict?))] 45 | [refocus* (-> pict? (non-empty-listof pict?) pict?)] 46 | [recenter (-> pict? real? real? pict?)] 47 | [recenter/tag (->* [pict? tag-path?] [pict-finder/c] pict?)] 48 | 49 | [maybe-colorize (-> pict? (or/c pict-color/c #f) pict?)] 50 | [set-smoothing (-> pict? (or/c 'unsmoothed 'smoothed 'aligned) pict?)] 51 | [adjust-pen (->* [pict?] 52 | [#:color (or/c string? (is-a?/c color%) #f) 53 | #:width (or/c (real-in 0 255) #f) 54 | #:style (or/c pen-style/c #f) 55 | #:cap (or/c pen-cap-style/c #f) 56 | #:join (or/c pen-join-style/c #f)] 57 | pict?)] 58 | #;[cellophane (-> pict? (real-in 0 1) pict?)] 59 | [metrics-frame (-> pict? pict?)] 60 | [rsvg-isolate (-> pict? pict?)] 61 | 62 | [line-append (-> pict? pict? ... pict?)] 63 | (struct spring ([weight real?])) 64 | [hflex (->* [real?] 65 | [#:combine (-> pict? pict? ... pict?)] 66 | #:rest (non-empty-listof (or/c pict? spring?)) 67 | pict?)])) 68 | 69 | ;; ----------------------------------------------------------------------------- 70 | ;; miscellany 71 | 72 | (define pict-color/c (or/c string? (is-a?/c color%) (list/c byte? byte? byte?))) 73 | (define pict-finder/c (-> pict? pict-path? (values real? real?))) 74 | 75 | (define (ppath-cons p path) 76 | (match path 77 | [#f p] 78 | [(? list?) (cons p path)] 79 | [(? pict?) (list p path)])) 80 | 81 | (define (ppath-last path) 82 | (match path 83 | [#f #f] 84 | [(list _ ... p) p] 85 | [(? pict? p) p])) 86 | 87 | (define ((adjust-find find dx dy) p path) 88 | (define-values [x y] (find p path)) 89 | (values (+ x dx) (+ y dy))) 90 | 91 | ;; ----------------------------------------------------------------------------- 92 | ;; conditionals 93 | 94 | (define (pict-when test then) 95 | (if test then (ghost then))) 96 | (define (pict-unless test then) 97 | (if test (ghost then) then)) 98 | 99 | (define (picts-take ps n) 100 | (for/list ([p (in-list ps)] 101 | [i (in-naturals)]) 102 | (if (< i n) p (ghost p)))) 103 | 104 | ;; ----------------------------------------------------------------------------- 105 | ;; parameters 106 | 107 | (define current-highlight-color (make-parameter (make-color #xFF #xB9 #xB5))) 108 | 109 | (define current-highlight-border-color 110 | (make-lazy-parameter 111 | (λ () 112 | (->color% (scale-color-value (current-highlight-color) 0.8))))) 113 | 114 | ;; ----------------------------------------------------------------------------- 115 | ;; constructors 116 | 117 | (define (line dx dy) 118 | (dc (λ (dc x y) (send dc draw-line x y (+ x dx) (+ y dy))) dx dy)) 119 | 120 | (define (arrow-line #:arrow-size [arrow-size 10] 121 | #:line-length [line-length 70] 122 | #:line-width [line-width 2]) 123 | (panorama (pin-over/align (linewidth line-width (hline line-length line-width)) 124 | line-length (/ line-width 2) 'c 'c 125 | (arrowhead arrow-size 0)))) 126 | 127 | (define (highlight p #:bleed [bleed 6] #:color [color (current-highlight-color)]) 128 | (define bg (filled-rectangle (+ (pict-width p) (* 2 bleed)) 129 | (+ (- (pict-height p) (pict-descent p)) (* 2 bleed)) 130 | #:draw-border? #f 131 | #:color color)) 132 | (refocus (cc-superimpose bg p) p)) 133 | (define (highlight-if c p #:bleed [bleed 6] #:color [color (current-highlight-color)]) 134 | (pict-if c (highlight p #:bleed bleed #:color color) p)) 135 | 136 | ; Adapted from pict. 137 | (define (file-icon w h) 138 | (dc (let* ([sw (lambda (x) (* (/ w 110) x))] 139 | [sh (lambda (y) (* (/ h 150) y))] 140 | [->pt (lambda (l) 141 | (map (lambda (p) 142 | (make-object point% 143 | (sw (car p)) 144 | (sh (cadr p)))) 145 | l))]) 146 | (lambda (dc x y) 147 | (send dc draw-polygon 148 | (->pt '((0 0) 149 | (0 150) 150 | (110 150) 151 | (110 20) 152 | (90 0))) 153 | x y) 154 | (send dc draw-line (+ x (sw 90)) (+ y 1) (+ x (sw 90)) (+ y (sh 20))) 155 | (send dc draw-line (+ x (sw 90)) (+ y (sh 20)) (+ x (sw 110) -1) (+ y (sh 20))))) 156 | w h)) 157 | 158 | ;; ----------------------------------------------------------------------------- 159 | ;; sizing / bounding box adjusters 160 | 161 | (define (em [n 1]) (* (pict-width (t "M")) n)) 162 | 163 | ; Drops the ascent line to the descent line, making the entire pict behave as a 164 | ; single line of text. 165 | (define (one-line p) 166 | (define ascent (- (pict-height p) (pict-descent p))) 167 | (pin-over (blank (pict-width p) (pict-height p) ascent (pict-descent p)) 0 0 p)) 168 | 169 | (define (indent #:by [n (em)] p) (inset p n 0 0 0)) 170 | 171 | ; Like `refocus` but shifts the bounding box to encompass all of a list of picts. 172 | (define (refocus* base-p sub-ps) 173 | (for/fold ([x1 +inf.0] 174 | [y1 +inf.0] 175 | [x2 -inf.0] 176 | [y2 -inf.0] 177 | #:result (pin-over (blank (- x2 x1) (- y2 y1)) (- x1) (- y1) base-p)) 178 | ([sub-p (in-list sub-ps)]) 179 | (define-values [sub-x1 sub-y1] (lt-find base-p sub-p)) 180 | (define-values [sub-x2 sub-y2] (rb-find base-p sub-p)) 181 | (values (min x1 sub-x1 sub-x2) 182 | (min y1 sub-y1 sub-y2) 183 | (max x2 sub-x1 sub-x2) 184 | (max y2 sub-y1 sub-y2)))) 185 | 186 | ; Convert the pict to a zero-sized pict centered at a particular location. 187 | (define pip 188 | (case-lambda 189 | [(p find) 190 | (pip p p find)] 191 | [(p a b) 192 | (define pinhole (blank)) 193 | (refocus (pin-over p a b pinhole) pinhole)])) 194 | 195 | ; Insets the given pict so that the given point is its center. 196 | (define (recenter p x y) 197 | (define h-inset (- (* x 2) (pict-width p))) 198 | (define v-inset (- (* y 2) (pict-height p))) 199 | (inset p 200 | (max 0 (- h-inset)) 201 | (max 0 (- v-inset)) 202 | (max 0 h-inset) 203 | (max 0 v-inset))) 204 | 205 | (define (recenter/tag p tag [find cc-find]) 206 | (define-values [x y] (find p (or (find-tag p tag) 207 | (raise-arguments-error 'recenter/tag "no sub-pict found with tag" "tag" tag)))) 208 | (recenter p x y)) 209 | 210 | ;; ----------------------------------------------------------------------------- 211 | ;; drawing adjusters 212 | 213 | (define (maybe-colorize p color) 214 | (if color (colorize p color) p)) 215 | 216 | (define (dc/wrap p proc) 217 | (define draw-p (make-pict-drawer p)) 218 | (struct-copy 219 | pict 220 | (dc (λ (dc dx dy) (proc draw-p dc dx dy)) 221 | (pict-width p) 222 | (pict-height p) 223 | (pict-ascent p) 224 | (pict-descent p)) 225 | [children (list (make-child p 0 0 1 1 0 0))] 226 | [last (pict-last p)])) 227 | 228 | (define (set-smoothing p smoothing) 229 | (define draw-p (make-pict-drawer p)) 230 | (struct-copy 231 | pict 232 | (dc (λ (dc dx dy) 233 | (define old-smoothing (send dc get-smoothing)) 234 | (send dc set-smoothing smoothing) 235 | (draw-p dc dx dy) 236 | (send dc set-smoothing old-smoothing)) 237 | (pict-width p) 238 | (pict-height p) 239 | (pict-ascent p) 240 | (pict-descent p)) 241 | [children (list (make-child p 0 0 1 1 0 0))] 242 | [last (pict-last p)])) 243 | 244 | (define (set-pen #:color [color (make-color 0 0 0)] 245 | #:width [width 0] 246 | #:style [style 'solid] 247 | #:cap [cap 'round] 248 | #:join [join 'round] 249 | p) 250 | (dc/wrap p (λ (draw-p dc dx dy) 251 | (define old-pen (send dc get-pen)) 252 | (send dc set-pen (make-pen #:color color 253 | #:width width 254 | #:style style 255 | #:cap cap 256 | #:join join)) 257 | (draw-p dc dx dy) 258 | (send dc set-pen old-pen)))) 259 | 260 | (define (adjust-pen #:color [color #f] 261 | #:width [width #f] 262 | #:style [style #f] 263 | #:cap [cap #f] 264 | #:join [join #f] 265 | p) 266 | (define draw-p (make-pict-drawer p)) 267 | (struct-copy 268 | pict 269 | (dc (λ (dc dx dy) 270 | (define old-pen (send dc get-pen)) 271 | (send dc set-pen (make-pen #:color (or color (send old-pen get-color)) 272 | #:width (or width (send old-pen get-width)) 273 | #:style (or style (send old-pen get-style)) 274 | #:cap (or cap (send old-pen get-cap)) 275 | #:join (or join (send old-pen get-join)) 276 | #:stipple (send old-pen get-stipple))) 277 | (draw-p dc dx dy) 278 | (send dc set-pen old-pen)) 279 | (pict-width p) 280 | (pict-height p) 281 | (pict-ascent p) 282 | (pict-descent p)) 283 | [children (list (make-child p 0 0 1 1 0 0))] 284 | [last (pict-last p)])) 285 | 286 | ; Like cellophane from pict, but blends the entire pict as a single group. 287 | #;(define (cellophane p opacity) 288 | (dc/wrap p (λ (draw-p dc dx dy) 289 | (define old-alpha (send dc get-alpha)) 290 | (send dc set-alpha 1) 291 | (send dc push-group) 292 | (draw-p dc dx dy) 293 | (send dc set-alpha (* old-alpha opacity)) 294 | (send dc draw-group) 295 | (send dc set-alpha old-alpha)))) 296 | 297 | ; For debugging: add bounding box lines to the given pict. 298 | (define (metrics-frame p) 299 | (define metrics-line (hline (pict-width p) 0)) 300 | (define a (pict-ascent p)) 301 | (define b (- (pict-height p) (pict-descent p))) 302 | (define metrics (~> (rectangle (pict-width p) (pict-height p)) 303 | (pin-over 0 a (adjust-pen metrics-line #:color "red")) 304 | (pin-over 0 b (adjust-pen metrics-line #:color "blue" 305 | #:style (if (< (abs (- a b)) 0.0001) 306 | 'long-dash 307 | 'solid))) 308 | (set-pen))) 309 | (pin-over p 0 0 metrics)) 310 | 311 | (define (rsvg-isolate p) 312 | (define draw-p (make-pict-drawer p)) 313 | (dc (λ (dc x y) 314 | ; for reasons I cannot fathom, this prevents rsvg from screwing up the 315 | ; color of subsequent draw operations 316 | (define old-pen (send dc get-pen)) 317 | (send dc set-pen (make-pen #:style 'transparent)) 318 | (send dc draw-point -inf.0 -inf.0) 319 | (send dc set-pen old-pen) 320 | (draw-p dc x y)) 321 | (pict-width p) 322 | (pict-height p) 323 | (pict-ascent p) 324 | (pict-descent p))) 325 | 326 | ;; ----------------------------------------------------------------------------- 327 | ;; combiners 328 | 329 | ; Combines picts by extending the last line, as determined by pict-last. 330 | (define (line-append p0 . ps) 331 | (foldl (λ (p2 p1) (line-append/2 p1 p2)) p0 ps)) 332 | (define (line-append/2 p1 p2) 333 | (define draw-p1 (make-pict-drawer p1)) 334 | (define draw-p2 (make-pict-drawer p2)) 335 | ; find the rightmost point on the baseline of (pict-last p1) 336 | (define-values [last-x last-y] (rbl-find p1 (or (pict-last p1) p1))) 337 | 338 | ; figure out where we’ll place p2 relative to p1, since we want to align the 339 | ; descent line of (pict-last p1) with the ascent line of p2 340 | (define p2-y-relative (- last-y (pict-ascent p2))) 341 | ; if p2-y is negative, that means p2’s ascent peeks out above the top of p1, 342 | ; so compute how far we need to offset p1/p2 relative to the top of the new pict 343 | (define p1-y (if (negative? p2-y-relative) (- p2-y-relative) 0)) 344 | (define p2-y (if (negative? p2-y-relative) 0 p2-y-relative)) 345 | 346 | ; the x coordinate is simpler, since we don’t have to deal with ascent/descent, 347 | ; but it’s possible (though unlikely) that last-x is negative, in which case we 348 | ; want to do a similar adjustment 349 | (define p1-x (if (negative? last-x) (- last-x) 0)) 350 | (define p2-x (if (negative? last-x) 0 last-x)) 351 | 352 | ; compute rightmost point and bottommost point in the new pict’s bounding box 353 | (define w (max (+ p1-x (pict-width p1)) 354 | (+ p2-x (pict-width p2)))) 355 | (define h (max (+ p1-y (pict-height p1)) 356 | (+ p2-y (pict-height p2)))) 357 | ; same for uppermost ascent line and lowermost descent line 358 | (define a (min (+ p1-y (pict-ascent p1)) 359 | (+ p2-y (pict-ascent p2)))) 360 | (define d (- h (max (+ p1-y (- (pict-height p1) (pict-descent p1))) 361 | (+ p2-y (- (pict-height p2) (pict-descent p2)))))) 362 | 363 | ; compute child offsets, which are weird because pict uses an inverted 364 | ; coordinate system, so these are relative to the lowermost point 365 | (define p1-dy (- h (+ p1-y (pict-height p1)))) 366 | (define p2-dy (- h (+ p2-y (pict-height p2)))) 367 | 368 | ; invent a new, totally unique pict to use as pict-last, in case (pict-last p2) 369 | ; already exists somewhere in the pict 370 | (define p2-last (or (ppath-last (pict-last p2)) p2)) 371 | (define-values [p2-last-x p2-last-y] (lt-find p2 (or (pict-last p2) p2))) 372 | (define last-p (blank (pict-width p2-last) 373 | (pict-height p2-last) 374 | (pict-ascent p2-last) 375 | (pict-descent p2-last))) 376 | 377 | (~> (dc (λ (dc dx dy) 378 | (draw-p1 dc (+ dx p1-x) (+ dy p1-y)) 379 | (draw-p2 dc (+ dx p2-x) (+ dy p2-y))) 380 | w h a d) 381 | (struct-copy pict _ 382 | [children (list (make-child p1 p1-x p1-dy 1 1 0 0) 383 | (make-child p2 p2-x p2-dy 1 1 0 0) 384 | (make-child last-p 385 | (+ p2-x p2-last-x) 386 | (+ p2-dy p2-last-y) 387 | 1 1 0 0))] 388 | [last last-p]))) 389 | 390 | (struct spring (weight) #:transparent) 391 | (define (hflex width #:combine [combine hc-append] . elements) 392 | (define fixed-width (for/sum ([e (in-list elements)] #:unless (spring? e)) (pict-width e))) 393 | (define flexi-width (- width fixed-width)) 394 | (define total-weight (for/sum ([e (in-list elements)] #:when (spring? e)) (spring-weight e))) 395 | (define width-per-weight (/ flexi-width total-weight)) 396 | (apply combine (for/list ([element (in-list elements)]) 397 | (match element 398 | [(spring weight) (blank (* weight width-per-weight) 0)] 399 | [_ element])))) 400 | -------------------------------------------------------------------------------- /2022-09-icfp-hiw/lib/slideshow.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (except-in pict cellophane file-icon) 4 | racket/contract 5 | racket/match 6 | slideshow/base 7 | slideshow/code 8 | slideshow/text 9 | threading 10 | 11 | (prefix-in slideshow: slideshow/base) 12 | 13 | "pict.rkt" 14 | "util.rkt") 15 | 16 | (provide (contract-out [current-slide-margin (parameter/c real?)] 17 | [make-scaling-slide-assembler (->* [] [#:background-color pict-color/c] 18 | (-> (or/c string? #f) 19 | exact-nonnegative-integer? 20 | pict? 21 | pict?))] 22 | 23 | [current-text-color (parameter/c (or/c pict-color/c #f))] 24 | [tt (-> string? pict?)] 25 | 26 | [para-spacing/c flat-contract?] 27 | [para-align/c flat-contract?] 28 | [current-para-spacing (parameter/c para-spacing/c)] 29 | [current-para-align (parameter/c para-align/c)] 30 | [current-para-fill? (parameter/c any/c)] 31 | [current-item-indent (parameter/c (or/c real? (-> real?)) real?)] 32 | [para (->* [] [#:width real? 33 | #:align para-align/c 34 | #:spacing para-spacing/c 35 | #:fill? any/c 36 | #:decode? any/c 37 | #:color (or/c pict-color/c #f)] 38 | #:rest (listof para-element/c) 39 | pict?)] 40 | [elem (->* [] [#:decode? any/c 41 | #:color (or/c pict-color/c #f)] 42 | #:rest (listof para-element/c) 43 | pict?)] 44 | [item (->* [] [#:width real? 45 | #:align para-align/c 46 | #:fill? any/c 47 | #:decode? any/c 48 | #:color (or/c pict-color/c #f)] 49 | #:rest (listof para-element/c) 50 | pict?)] 51 | [resolve-para-spacing (->* [] [para-spacing/c] real?)] 52 | [paras (->* [] [#:align para-align/c 53 | #:spacing para-spacing/c 54 | #:stage (or/c exact-integer? #f)] 55 | #:rest (listof pict?) 56 | pict?)])) 57 | 58 | ;; ----------------------------------------------------------------------------- 59 | ;; slide assembler 60 | 61 | (define current-slide-margin (make-parameter 20)) 62 | 63 | (define ((make-scaling-slide-assembler #:background-color [background-color "white"]) 64 | title-str gap content) 65 | (define background 66 | (inset (filled-rectangle (+ client-w (* margin 2)) 67 | (+ client-h (* margin 2)) 68 | #:draw-border? #f 69 | #:color background-color) 70 | (- margin))) 71 | (define title (and title-str (~> ((current-titlet) title-str) 72 | (scale-to-fit client-w title-h)))) 73 | (define content-area 74 | (~> (if title 75 | (blank (pict-width background) 76 | (- (pict-height background) 77 | (pict-height title) 78 | gap)) 79 | (ghost background)) 80 | (inset (- (current-slide-margin))))) 81 | (define bounded-content (scale-to-fit content content-area #:mode 'inset)) 82 | (define title+content (if title (vc-append gap title bounded-content) bounded-content)) 83 | (cc-superimpose background title+content)) 84 | 85 | ;; ----------------------------------------------------------------------------- 86 | ;; text and layout 87 | 88 | (define current-text-color (make-parameter #f)) 89 | 90 | (define (tt s) 91 | (with-font (current-code-font) 92 | (with-size ((get-current-code-font-size)) (t s)))) 93 | 94 | (define para-spacing/c (or/c real? (list/c 'lines real?))) 95 | (define para-align/c (or/c 'left 'center 'right)) 96 | (define para-element/c (flat-rec-contract elem/c 97 | (or/c string? pict? (listof elem/c)))) 98 | 99 | (define current-para-spacing (make-parameter '(lines 0.2))) 100 | (define current-para-align (make-parameter 'left)) 101 | (define current-para-fill? (make-parameter #t (λ (v) (and v #t)))) 102 | (define current-item-indent (make-lazy-parameter em)) 103 | 104 | (define (para #:width [width (current-para-width)] 105 | #:align [align (current-para-align)] 106 | #:spacing [spacing (current-line-sep)] 107 | #:fill? [fill? (current-para-fill?)] 108 | #:decode? [decode? #t] 109 | #:color [color (current-text-color)] 110 | . elements) 111 | (parameterize ([current-line-sep (resolve-para-spacing spacing)]) 112 | (~> (apply slideshow:para #:width width #:align align #:fill? fill? #:decode? decode? elements) 113 | (maybe-colorize color)))) 114 | 115 | (define (elem #:decode? [decode? #t] 116 | #:color [color (current-text-color)] 117 | . elements) 118 | (apply para #:width +inf.0 #:fill? #f #:decode? decode? #:color color elements)) 119 | 120 | (define (item #:width [width (current-para-width)] 121 | #:align [align (current-para-align)] 122 | #:indent [indent (current-item-indent)] 123 | #:fill? [fill? (current-para-fill?)] 124 | #:decode? [decode? #t] 125 | #:color [color (current-text-color)] 126 | . elements) 127 | (define bullet (htl-append (blank indent 0) (elem "→") (blank (em 0.75) 0))) 128 | (htl-append bullet 129 | (apply para #:width (- width (pict-width bullet)) 130 | #:align align #:fill? fill? #:decode? decode? elements))) 131 | 132 | (define (resolve-para-spacing [spacing (current-para-spacing)]) 133 | (match spacing 134 | [(? real?) spacing] 135 | [(list 'lines n) (* (current-font-size) n)])) 136 | 137 | (define (paras #:align [align (current-para-align)] 138 | #:spacing [spacing (current-para-spacing)] 139 | #:stage [stage #f] 140 | . elements) 141 | (apply (match align 142 | ['left vl-append] 143 | ['center vc-append] 144 | ['right vr-append]) 145 | (resolve-para-spacing spacing) 146 | (for/list ([element (in-list elements)] 147 | [i (in-naturals)]) 148 | (pict-when (or (not stage) (< i stage)) element)))) 149 | -------------------------------------------------------------------------------- /2022-09-icfp-hiw/lib/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | racket/function 5 | racket/math 6 | syntax/parse/define 7 | threading) 8 | 9 | (provide when~> 10 | (contract-out [make-lazy-parameter (-> any/c parameter?)] 11 | [lazy-parameter/c (->* [contract?] [contract?] contract?)] 12 | [turns (-> real? real?)])) 13 | 14 | (define (make-lazy-parameter val) 15 | (make-derived-parameter (make-parameter val) 16 | identity 17 | (λ (v) (if (procedure? v) (v) v)))) 18 | 19 | (define (lazy-parameter/c in-ctc [out-ctc in-ctc]) 20 | (parameter/c (or/c in-ctc (-> in-ctc)) out-ctc)) 21 | 22 | (define-simple-macro (when~> e:expr c:expr s:expr ...) 23 | (let ([v e]) (if c (~> v s ...) v))) 24 | 25 | (define (turns n) (* 2 pi n)) 26 | -------------------------------------------------------------------------------- /2022-11-haskell-exchange/assets/mercury-icon.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /2022-11-haskell-exchange/assets/mercury-text.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /2022-11-haskell-exchange/assets/screenshot-issue-21700-th-linking.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2022-11-haskell-exchange/assets/screenshot-issue-21700-th-linking.png -------------------------------------------------------------------------------- /2022-11-haskell-exchange/assets/screenshot-issue-21853-codegen-printer.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2022-11-haskell-exchange/assets/screenshot-issue-21853-codegen-printer.png -------------------------------------------------------------------------------- /2022-11-haskell-exchange/assets/screenshot-issue-bytecode-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2022-11-haskell-exchange/assets/screenshot-issue-bytecode-1.png -------------------------------------------------------------------------------- /2022-11-haskell-exchange/assets/screenshot-issue-bytecode-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2022-11-haskell-exchange/assets/screenshot-issue-bytecode-2.png -------------------------------------------------------------------------------- /2022-11-haskell-exchange/assets/screenshot-issue-bytecode-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2022-11-haskell-exchange/assets/screenshot-issue-bytecode-3.png -------------------------------------------------------------------------------- /2022-11-haskell-exchange/assets/screenshot-mr-7502-fat-interface-files.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2022-11-haskell-exchange/assets/screenshot-mr-7502-fat-interface-files.png -------------------------------------------------------------------------------- /2022-11-haskell-exchange/assets/tweag.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /2022-11-haskell-exchange/lib/color.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/struct-info) 5 | racket/class 6 | racket/contract 7 | racket/draw 8 | racket/match 9 | threading) 10 | 11 | (provide (rename-out [rgb* rgb] [hsv* hsv]) 12 | rgb-red rgb-green rgb-blue rgb-alpha 13 | hsv-hue hsv-saturation hsv-value hsv-alpha 14 | 15 | (contract-out 16 | [color? predicate/c] 17 | [->color% (-> color? (is-a?/c color%))] 18 | [->rgb (-> color? rgb?)] 19 | [->hsv (-> color? hsv?)] 20 | 21 | [scale-color-value (-> color? (>=/c 0) color?)] 22 | [add-color-value (-> color? real? color?)])) 23 | 24 | ;; ----------------------------------------------------------------------------- 25 | 26 | (define (fmod x n) 27 | (define i (floor x)) 28 | (+ (remainder i n) (- x i))) 29 | 30 | (struct rgb (red green blue alpha) #:transparent 31 | #:guard (struct-guard/c (real-in 0 1) (real-in 0 1) (real-in 0 1) (real-in 0 1))) 32 | (struct hsv (hue saturation value alpha) #:transparent 33 | #:guard (struct-guard/c (real-in 0 1) (real-in 0 1) (real-in 0 1) (real-in 0 1))) 34 | 35 | (define (make-rgb r g b [alpha 1.0]) 36 | (rgb r g b alpha)) 37 | (define (make-hsv h s v [alpha 1.0]) 38 | (define h* (- h (truncate h))) 39 | (hsv (if (< h* 0.0) (+ 1.0 h*) h*) s v alpha)) 40 | 41 | (begin-for-syntax 42 | (struct struct-info (ctor-id list field-syms) #:transparent 43 | #:property prop:struct-info (λ (self) (struct-info-list self)) 44 | #:property prop:struct-field-info (λ (self) (struct-info-field-syms self)) 45 | #:property prop:expansion-contexts '(expression) 46 | #:property prop:procedure 47 | (λ (self stx) 48 | (define ctor-id (struct-info-ctor-id self)) 49 | (syntax-case stx () 50 | [id (identifier? #'id) ctor-id] 51 | [(_ . args) (datum->syntax stx (cons ctor-id #'args) stx)]))) 52 | (define (make-custom-ctor-struct-info base-id ctor-id) 53 | (define base-info (syntax-local-value base-id)) 54 | (define base-list (extract-struct-info base-info)) 55 | (define base-fields (struct-field-info-list base-info)) 56 | (struct-info ctor-id 57 | (list* (car base-list) ctor-id (cddr base-list)) 58 | base-fields))) 59 | 60 | (define-syntax rgb* (make-custom-ctor-struct-info #'rgb #'make-rgb)) 61 | (define-syntax hsv* (make-custom-ctor-struct-info #'hsv #'make-hsv)) 62 | 63 | (define (hsv->rgb h s v [alpha 1.0]) 64 | (define (f n) 65 | (define k (fmod (+ n (* h 6.0)) 6)) 66 | (- v (* v s (max 0.0 (min k (- 4.0 k) 1.0))))) 67 | (rgb (f 5.0) (f 3.0) (f 1.0) alpha)) 68 | 69 | (define (rgb->hsv r g b [alpha 1.0]) 70 | (define v (max r g b)) 71 | (define chroma (- v (min r g b))) 72 | (define h (cond 73 | [(zero? chroma) 0.0] 74 | [(= v r) (/ (/ (- g b) chroma) 6.0)] 75 | [(= v g) (/ (+ 2.0 (/ (- b r) chroma)) 6.0)] 76 | [else (/ (+ 4.0 (/ (- r g) chroma)) 6.0)])) 77 | (define s (if (zero? chroma) 0 (/ chroma v))) 78 | (hsv h s v alpha)) 79 | 80 | ;; ----------------------------------------------------------------------------- 81 | 82 | (define (color? v) 83 | (or (is-a? v color%) 84 | (rgb? v) 85 | (hsv? v) 86 | (and (string? v) 87 | (send the-color-database find-color v) 88 | #t))) 89 | 90 | (define (find-color% who name) 91 | (or (send the-color-database find-color name) 92 | (raise-arguments-error who "no known color with name" "name" name))) 93 | 94 | (define (->color% v) 95 | (match v 96 | [(? (λ~> (is-a? color%))) v] 97 | [(rgb r g b a) 98 | (define (f n) (inexact->exact (round (max 0 (min (* n 255) 255))))) 99 | (make-color (f r) (f g) (f b) a)] 100 | [(hsv h s v a) 101 | (->color% (hsv->rgb h s v a))] 102 | [(? string?) 103 | (find-color% '->color% v)])) 104 | 105 | (define (->rgb v) 106 | (match v 107 | [(? rgb?) v] 108 | [(? (λ~> (is-a? color%))) 109 | (rgb (/ (send v red) 255.0) 110 | (/ (send v green) 255.0) 111 | (/ (send v blue) 255.0) 112 | (send v alpha))] 113 | [(hsv h s v a) 114 | (hsv->rgb h s v a)] 115 | [(? string?) 116 | (->rgb (find-color% '->rgb v))])) 117 | 118 | (define (->hsv v) 119 | (match v 120 | [(? hsv?) v] 121 | [(? (λ~> (is-a? color%))) 122 | (rgb->hsv (/ (send v red) 255.0) 123 | (/ (send v green) 255.0) 124 | (/ (send v blue) 255.0) 125 | (send v alpha))] 126 | [(rgb r g b a) 127 | (rgb->hsv r g b a)] 128 | [(? string?) 129 | (->hsv (find-color% '->hsv v))])) 130 | 131 | ;; ----------------------------------------------------------------------------- 132 | 133 | (define (scale-color-value color fac) 134 | (match-define (hsv h s v a) (->hsv color)) 135 | (hsv h s (min (* v fac) 1) a)) 136 | 137 | (define (add-color-value color amt) 138 | (match-define (hsv h s v a) (->hsv color)) 139 | (hsv h s (max 0 (min (+ v amt) 1)) a)) 140 | -------------------------------------------------------------------------------- /2022-11-haskell-exchange/lib/pict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require pict 4 | pict/conditional 5 | ppict/align 6 | ppict/tag 7 | racket/class 8 | racket/contract 9 | racket/draw 10 | racket/match 11 | slideshow/base 12 | threading 13 | "color.rkt" 14 | "util.rkt") 15 | 16 | (provide (contract-out [pict-color/c flat-contract?] 17 | [pict-finder/c chaperone-contract?] 18 | [ppath-cons (-> pict? (or/c pict-path? #f) pict-path?)] 19 | [adjust-find (-> pict-finder/c real? real? pict-finder/c)] 20 | 21 | [pict-when (-> any/c pict? pict?)] 22 | [pict-unless (-> any/c pict? pict?)] 23 | [picts-take (-> (listof pict?) exact-nonnegative-integer? (listof pict?))] 24 | 25 | [current-highlight-color (parameter/c pict-color/c)] 26 | [current-highlight-border-color (lazy-parameter/c pict-color/c)] 27 | 28 | [line (-> real? real? pict?)] 29 | [arrow-line (->* [] [#:arrow-size real? 30 | #:line-length real? 31 | #:line-width real?] 32 | pict?)] 33 | [highlight (->* [pict?] [#:bleed real? #:color pict-color/c] pict?)] 34 | [highlight-if (->* [any/c pict?] [#:bleed real? #:color pict-color/c] pict?)] 35 | [file-icon (-> real? real? pict?)] 36 | 37 | [em (->* [] [real?] real?)] 38 | [one-line (-> pict? pict?)] 39 | [indent (->* [pict?] [#:by real?] pict?)] 40 | [pip (case-> (-> pict? pict-finder/c pict?) 41 | (-> pict? 42 | (or/c real? pict-path?) 43 | (or/c real? pict-finder/c) 44 | pict?))] 45 | [refocus* (-> pict? (non-empty-listof pict?) pict?)] 46 | [recenter (-> pict? real? real? pict?)] 47 | [recenter/tag (->* [pict? tag-path?] [pict-finder/c] pict?)] 48 | 49 | [maybe-colorize (-> pict? (or/c pict-color/c #f) pict?)] 50 | [set-smoothing (-> pict? (or/c 'unsmoothed 'smoothed 'aligned) pict?)] 51 | [adjust-pen (->* [pict?] 52 | [#:color (or/c string? (is-a?/c color%) #f) 53 | #:width (or/c (real-in 0 255) #f) 54 | #:style (or/c pen-style/c #f) 55 | #:cap (or/c pen-cap-style/c #f) 56 | #:join (or/c pen-join-style/c #f)] 57 | pict?)] 58 | #;[cellophane (-> pict? (real-in 0 1) pict?)] 59 | [metrics-frame (-> pict? pict?)] 60 | [rsvg-isolate (-> pict? pict?)] 61 | 62 | [line-append (-> pict? pict? ... pict?)] 63 | (struct spring ([weight real?])) 64 | [hflex (->* [real?] 65 | [#:combine (-> pict? pict? ... pict?)] 66 | #:rest (non-empty-listof (or/c pict? spring?)) 67 | pict?)])) 68 | 69 | ;; ----------------------------------------------------------------------------- 70 | ;; miscellany 71 | 72 | (define pict-color/c (or/c string? (is-a?/c color%) (list/c byte? byte? byte?))) 73 | (define pict-finder/c (-> pict? pict-path? (values real? real?))) 74 | 75 | (define (ppath-cons p path) 76 | (match path 77 | [#f p] 78 | [(? list?) (cons p path)] 79 | [(? pict?) (list p path)])) 80 | 81 | (define (ppath-last path) 82 | (match path 83 | [#f #f] 84 | [(list _ ... p) p] 85 | [(? pict? p) p])) 86 | 87 | (define ((adjust-find find dx dy) p path) 88 | (define-values [x y] (find p path)) 89 | (values (+ x dx) (+ y dy))) 90 | 91 | ;; ----------------------------------------------------------------------------- 92 | ;; conditionals 93 | 94 | (define (pict-when test then) 95 | (if test then (ghost then))) 96 | (define (pict-unless test then) 97 | (if test (ghost then) then)) 98 | 99 | (define (picts-take ps n) 100 | (for/list ([p (in-list ps)] 101 | [i (in-naturals)]) 102 | (if (< i n) p (ghost p)))) 103 | 104 | ;; ----------------------------------------------------------------------------- 105 | ;; parameters 106 | 107 | (define current-highlight-color (make-parameter (make-color #xFF #xB9 #xB5))) 108 | 109 | (define current-highlight-border-color 110 | (make-lazy-parameter 111 | (λ () 112 | (->color% (scale-color-value (current-highlight-color) 0.8))))) 113 | 114 | ;; ----------------------------------------------------------------------------- 115 | ;; constructors 116 | 117 | (define (line dx dy) 118 | (dc (λ (dc x y) (send dc draw-line x y (+ x dx) (+ y dy))) dx dy)) 119 | 120 | (define (arrow-line #:arrow-size [arrow-size 10] 121 | #:line-length [line-length 70] 122 | #:line-width [line-width 2]) 123 | (panorama (pin-over/align (linewidth line-width (hline line-length line-width)) 124 | line-length (/ line-width 2) 'c 'c 125 | (arrowhead arrow-size 0)))) 126 | 127 | (define (highlight p #:bleed [bleed 6] #:color [color (current-highlight-color)]) 128 | (define bg (filled-rectangle (+ (pict-width p) (* 2 bleed)) 129 | (+ (- (pict-height p) (pict-descent p)) (* 2 bleed)) 130 | #:draw-border? #f 131 | #:color color)) 132 | (refocus (cc-superimpose bg p) p)) 133 | (define (highlight-if c p #:bleed [bleed 6] #:color [color (current-highlight-color)]) 134 | (pict-if c (highlight p #:bleed bleed #:color color) p)) 135 | 136 | ; Adapted from pict. 137 | (define (file-icon w h) 138 | (dc (let* ([sw (lambda (x) (* (/ w 110) x))] 139 | [sh (lambda (y) (* (/ h 150) y))] 140 | [->pt (lambda (l) 141 | (map (lambda (p) 142 | (make-object point% 143 | (sw (car p)) 144 | (sh (cadr p)))) 145 | l))]) 146 | (lambda (dc x y) 147 | (send dc draw-polygon 148 | (->pt '((0 0) 149 | (0 150) 150 | (110 150) 151 | (110 20) 152 | (90 0))) 153 | x y) 154 | (send dc draw-line (+ x (sw 90)) (+ y 1) (+ x (sw 90)) (+ y (sh 20))) 155 | (send dc draw-line (+ x (sw 90)) (+ y (sh 20)) (+ x (sw 110) -1) (+ y (sh 20))))) 156 | w h)) 157 | 158 | ;; ----------------------------------------------------------------------------- 159 | ;; sizing / bounding box adjusters 160 | 161 | (define (em [n 1]) (* (pict-width (t "M")) n)) 162 | 163 | ; Drops the ascent line to the descent line, making the entire pict behave as a 164 | ; single line of text. 165 | (define (one-line p) 166 | (define ascent (- (pict-height p) (pict-descent p))) 167 | (pin-over (blank (pict-width p) (pict-height p) ascent (pict-descent p)) 0 0 p)) 168 | 169 | (define (indent #:by [n (em)] p) (inset p n 0 0 0)) 170 | 171 | ; Like `refocus` but shifts the bounding box to encompass all of a list of picts. 172 | (define (refocus* base-p sub-ps) 173 | (for/fold ([x1 +inf.0] 174 | [y1 +inf.0] 175 | [x2 -inf.0] 176 | [y2 -inf.0] 177 | #:result (pin-over (blank (- x2 x1) (- y2 y1)) (- x1) (- y1) base-p)) 178 | ([sub-p (in-list sub-ps)]) 179 | (define-values [sub-x1 sub-y1] (lt-find base-p sub-p)) 180 | (define-values [sub-x2 sub-y2] (rb-find base-p sub-p)) 181 | (values (min x1 sub-x1 sub-x2) 182 | (min y1 sub-y1 sub-y2) 183 | (max x2 sub-x1 sub-x2) 184 | (max y2 sub-y1 sub-y2)))) 185 | 186 | ; Convert the pict to a zero-sized pict centered at a particular location. 187 | (define pip 188 | (case-lambda 189 | [(p find) 190 | (pip p p find)] 191 | [(p a b) 192 | (define pinhole (blank)) 193 | (refocus (pin-over p a b pinhole) pinhole)])) 194 | 195 | ; Insets the given pict so that the given point is its center. 196 | (define (recenter p x y) 197 | (define h-inset (- (* x 2) (pict-width p))) 198 | (define v-inset (- (* y 2) (pict-height p))) 199 | (inset p 200 | (max 0 (- h-inset)) 201 | (max 0 (- v-inset)) 202 | (max 0 h-inset) 203 | (max 0 v-inset))) 204 | 205 | (define (recenter/tag p tag [find cc-find]) 206 | (define-values [x y] (find p (or (find-tag p tag) 207 | (raise-arguments-error 'recenter/tag "no sub-pict found with tag" "tag" tag)))) 208 | (recenter p x y)) 209 | 210 | ;; ----------------------------------------------------------------------------- 211 | ;; drawing adjusters 212 | 213 | (define (maybe-colorize p color) 214 | (if color (colorize p color) p)) 215 | 216 | (define (dc/wrap p proc) 217 | (define draw-p (make-pict-drawer p)) 218 | (struct-copy 219 | pict 220 | (dc (λ (dc dx dy) (proc draw-p dc dx dy)) 221 | (pict-width p) 222 | (pict-height p) 223 | (pict-ascent p) 224 | (pict-descent p)) 225 | [children (list (make-child p 0 0 1 1 0 0))] 226 | [last (pict-last p)])) 227 | 228 | (define (set-smoothing p smoothing) 229 | (define draw-p (make-pict-drawer p)) 230 | (struct-copy 231 | pict 232 | (dc (λ (dc dx dy) 233 | (define old-smoothing (send dc get-smoothing)) 234 | (send dc set-smoothing smoothing) 235 | (draw-p dc dx dy) 236 | (send dc set-smoothing old-smoothing)) 237 | (pict-width p) 238 | (pict-height p) 239 | (pict-ascent p) 240 | (pict-descent p)) 241 | [children (list (make-child p 0 0 1 1 0 0))] 242 | [last (pict-last p)])) 243 | 244 | (define (set-pen #:color [color (make-color 0 0 0)] 245 | #:width [width 0] 246 | #:style [style 'solid] 247 | #:cap [cap 'round] 248 | #:join [join 'round] 249 | p) 250 | (dc/wrap p (λ (draw-p dc dx dy) 251 | (define old-pen (send dc get-pen)) 252 | (send dc set-pen (make-pen #:color color 253 | #:width width 254 | #:style style 255 | #:cap cap 256 | #:join join)) 257 | (draw-p dc dx dy) 258 | (send dc set-pen old-pen)))) 259 | 260 | (define (adjust-pen #:color [color #f] 261 | #:width [width #f] 262 | #:style [style #f] 263 | #:cap [cap #f] 264 | #:join [join #f] 265 | p) 266 | (define draw-p (make-pict-drawer p)) 267 | (struct-copy 268 | pict 269 | (dc (λ (dc dx dy) 270 | (define old-pen (send dc get-pen)) 271 | (send dc set-pen (make-pen #:color (or color (send old-pen get-color)) 272 | #:width (or width (send old-pen get-width)) 273 | #:style (or style (send old-pen get-style)) 274 | #:cap (or cap (send old-pen get-cap)) 275 | #:join (or join (send old-pen get-join)) 276 | #:stipple (send old-pen get-stipple))) 277 | (draw-p dc dx dy) 278 | (send dc set-pen old-pen)) 279 | (pict-width p) 280 | (pict-height p) 281 | (pict-ascent p) 282 | (pict-descent p)) 283 | [children (list (make-child p 0 0 1 1 0 0))] 284 | [last (pict-last p)])) 285 | 286 | ; Like cellophane from pict, but blends the entire pict as a single group. 287 | #;(define (cellophane p opacity) 288 | (dc/wrap p (λ (draw-p dc dx dy) 289 | (define old-alpha (send dc get-alpha)) 290 | (send dc set-alpha 1) 291 | (send dc push-group) 292 | (draw-p dc dx dy) 293 | (send dc set-alpha (* old-alpha opacity)) 294 | (send dc draw-group) 295 | (send dc set-alpha old-alpha)))) 296 | 297 | ; For debugging: add bounding box lines to the given pict. 298 | (define (metrics-frame p) 299 | (define metrics-line (hline (pict-width p) 0)) 300 | (define a (pict-ascent p)) 301 | (define b (- (pict-height p) (pict-descent p))) 302 | (define metrics (~> (rectangle (pict-width p) (pict-height p)) 303 | (pin-over 0 a (adjust-pen metrics-line #:color "red")) 304 | (pin-over 0 b (adjust-pen metrics-line #:color "blue" 305 | #:style (if (< (abs (- a b)) 0.0001) 306 | 'long-dash 307 | 'solid))) 308 | (set-pen))) 309 | (pin-over p 0 0 metrics)) 310 | 311 | (define (rsvg-isolate p) 312 | (define draw-p (make-pict-drawer p)) 313 | (dc (λ (dc x y) 314 | ; for reasons I cannot fathom, this prevents rsvg from screwing up the 315 | ; color of subsequent draw operations 316 | (define old-pen (send dc get-pen)) 317 | (send dc set-pen (make-pen #:style 'transparent)) 318 | (send dc draw-point -inf.0 -inf.0) 319 | (send dc set-pen old-pen) 320 | (draw-p dc x y)) 321 | (pict-width p) 322 | (pict-height p) 323 | (pict-ascent p) 324 | (pict-descent p))) 325 | 326 | ;; ----------------------------------------------------------------------------- 327 | ;; combiners 328 | 329 | ; Combines picts by extending the last line, as determined by pict-last. 330 | (define (line-append p0 . ps) 331 | (foldl (λ (p2 p1) (line-append/2 p1 p2)) p0 ps)) 332 | (define (line-append/2 p1 p2) 333 | (define draw-p1 (make-pict-drawer p1)) 334 | (define draw-p2 (make-pict-drawer p2)) 335 | ; find the rightmost point on the baseline of (pict-last p1) 336 | (define-values [last-x last-y] (rbl-find p1 (or (pict-last p1) p1))) 337 | 338 | ; figure out where we’ll place p2 relative to p1, since we want to align the 339 | ; descent line of (pict-last p1) with the ascent line of p2 340 | (define p2-y-relative (- last-y (pict-ascent p2))) 341 | ; if p2-y is negative, that means p2’s ascent peeks out above the top of p1, 342 | ; so compute how far we need to offset p1/p2 relative to the top of the new pict 343 | (define p1-y (if (negative? p2-y-relative) (- p2-y-relative) 0)) 344 | (define p2-y (if (negative? p2-y-relative) 0 p2-y-relative)) 345 | 346 | ; the x coordinate is simpler, since we don’t have to deal with ascent/descent, 347 | ; but it’s possible (though unlikely) that last-x is negative, in which case we 348 | ; want to do a similar adjustment 349 | (define p1-x (if (negative? last-x) (- last-x) 0)) 350 | (define p2-x (if (negative? last-x) 0 last-x)) 351 | 352 | ; compute rightmost point and bottommost point in the new pict’s bounding box 353 | (define w (max (+ p1-x (pict-width p1)) 354 | (+ p2-x (pict-width p2)))) 355 | (define h (max (+ p1-y (pict-height p1)) 356 | (+ p2-y (pict-height p2)))) 357 | ; same for uppermost ascent line and lowermost descent line 358 | (define a (min (+ p1-y (pict-ascent p1)) 359 | (+ p2-y (pict-ascent p2)))) 360 | (define d (- h (max (+ p1-y (- (pict-height p1) (pict-descent p1))) 361 | (+ p2-y (- (pict-height p2) (pict-descent p2)))))) 362 | 363 | ; compute child offsets, which are weird because pict uses an inverted 364 | ; coordinate system, so these are relative to the lowermost point 365 | (define p1-dy (- h (+ p1-y (pict-height p1)))) 366 | (define p2-dy (- h (+ p2-y (pict-height p2)))) 367 | 368 | ; invent a new, totally unique pict to use as pict-last, in case (pict-last p2) 369 | ; already exists somewhere in the pict 370 | (define p2-last (or (ppath-last (pict-last p2)) p2)) 371 | (define-values [p2-last-x p2-last-y] (lt-find p2 (or (pict-last p2) p2))) 372 | (define last-p (blank (pict-width p2-last) 373 | (pict-height p2-last) 374 | (pict-ascent p2-last) 375 | (pict-descent p2-last))) 376 | 377 | (~> (dc (λ (dc dx dy) 378 | (draw-p1 dc (+ dx p1-x) (+ dy p1-y)) 379 | (draw-p2 dc (+ dx p2-x) (+ dy p2-y))) 380 | w h a d) 381 | (struct-copy pict _ 382 | [children (list (make-child p1 p1-x p1-dy 1 1 0 0) 383 | (make-child p2 p2-x p2-dy 1 1 0 0) 384 | (make-child last-p 385 | (+ p2-x p2-last-x) 386 | (+ p2-dy p2-last-y) 387 | 1 1 0 0))] 388 | [last last-p]))) 389 | 390 | (struct spring (weight) #:transparent) 391 | (define (hflex width #:combine [combine hc-append] . elements) 392 | (define fixed-width (for/sum ([e (in-list elements)] #:unless (spring? e)) (pict-width e))) 393 | (define flexi-width (- width fixed-width)) 394 | (define total-weight (for/sum ([e (in-list elements)] #:when (spring? e)) (spring-weight e))) 395 | (define width-per-weight (/ flexi-width total-weight)) 396 | (apply combine (for/list ([element (in-list elements)]) 397 | (match element 398 | [(spring weight) (blank (* weight width-per-weight) 0)] 399 | [_ element])))) 400 | -------------------------------------------------------------------------------- /2022-11-haskell-exchange/lib/slideshow.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (except-in pict cellophane file-icon) 4 | racket/contract 5 | racket/match 6 | slideshow/base 7 | slideshow/code 8 | slideshow/text 9 | threading 10 | 11 | (prefix-in slideshow: slideshow/base) 12 | 13 | "pict.rkt" 14 | "util.rkt") 15 | 16 | (provide (contract-out [current-slide-margin (parameter/c real?)] 17 | [make-scaling-slide-assembler (->* [] [#:background-color pict-color/c] 18 | (-> (or/c string? #f) 19 | exact-nonnegative-integer? 20 | pict? 21 | pict?))] 22 | 23 | [current-text-color (parameter/c (or/c pict-color/c #f))] 24 | [tt (-> string? pict?)] 25 | 26 | [para-spacing/c flat-contract?] 27 | [para-align/c flat-contract?] 28 | [current-para-spacing (parameter/c para-spacing/c)] 29 | [current-para-align (parameter/c para-align/c)] 30 | [current-para-fill? (parameter/c any/c)] 31 | [current-item-indent (parameter/c (or/c real? (-> real?)) real?)] 32 | [para (->* [] [#:width real? 33 | #:align para-align/c 34 | #:spacing para-spacing/c 35 | #:fill? any/c 36 | #:decode? any/c 37 | #:color (or/c pict-color/c #f)] 38 | #:rest (listof para-element/c) 39 | pict?)] 40 | [elem (->* [] [#:decode? any/c 41 | #:color (or/c pict-color/c #f)] 42 | #:rest (listof para-element/c) 43 | pict?)] 44 | [item (->* [] [#:width real? 45 | #:align para-align/c 46 | #:fill? any/c 47 | #:decode? any/c 48 | #:color (or/c pict-color/c #f)] 49 | #:rest (listof para-element/c) 50 | pict?)] 51 | [resolve-para-spacing (->* [] [para-spacing/c] real?)] 52 | [paras (->* [] [#:align para-align/c 53 | #:spacing para-spacing/c 54 | #:stage (or/c exact-integer? #f)] 55 | #:rest (listof pict?) 56 | pict?)])) 57 | 58 | ;; ----------------------------------------------------------------------------- 59 | ;; slide assembler 60 | 61 | (define current-slide-margin (make-parameter 20)) 62 | 63 | (define ((make-scaling-slide-assembler #:background-color [background-color "white"]) 64 | title-str gap content) 65 | (define background 66 | (inset (filled-rectangle (+ client-w (* margin 2)) 67 | (+ client-h (* margin 2)) 68 | #:draw-border? #f 69 | #:color background-color) 70 | (- margin))) 71 | (define title (and title-str (~> ((current-titlet) title-str) 72 | (scale-to-fit client-w title-h)))) 73 | (define content-area 74 | (~> (if title 75 | (blank (pict-width background) 76 | (- (pict-height background) 77 | (pict-height title) 78 | gap)) 79 | (ghost background)) 80 | (inset (- (current-slide-margin))))) 81 | (define bounded-content (scale-to-fit content content-area #:mode 'inset)) 82 | (define title+content (if title (vc-append gap title bounded-content) bounded-content)) 83 | (cc-superimpose background title+content)) 84 | 85 | ;; ----------------------------------------------------------------------------- 86 | ;; text and layout 87 | 88 | (define current-text-color (make-parameter #f)) 89 | 90 | (define (tt s) 91 | (with-font (current-code-font) 92 | (with-size ((get-current-code-font-size)) (t s)))) 93 | 94 | (define para-spacing/c (or/c real? (list/c 'lines real?))) 95 | (define para-align/c (or/c 'left 'center 'right)) 96 | (define para-element/c (flat-rec-contract elem/c 97 | (or/c string? pict? (listof elem/c)))) 98 | 99 | (define current-para-spacing (make-parameter '(lines 0.2))) 100 | (define current-para-align (make-parameter 'left)) 101 | (define current-para-fill? (make-parameter #t (λ (v) (and v #t)))) 102 | (define current-item-indent (make-lazy-parameter em)) 103 | 104 | (define (para #:width [width (current-para-width)] 105 | #:align [align (current-para-align)] 106 | #:spacing [spacing (current-line-sep)] 107 | #:fill? [fill? (current-para-fill?)] 108 | #:decode? [decode? #t] 109 | #:color [color (current-text-color)] 110 | . elements) 111 | (parameterize ([current-line-sep (resolve-para-spacing spacing)]) 112 | (~> (apply slideshow:para #:width width #:align align #:fill? fill? #:decode? decode? elements) 113 | (maybe-colorize color)))) 114 | 115 | (define (elem #:decode? [decode? #t] 116 | #:color [color (current-text-color)] 117 | . elements) 118 | (apply para #:width +inf.0 #:fill? #f #:decode? decode? #:color color elements)) 119 | 120 | (define (item #:width [width (current-para-width)] 121 | #:align [align (current-para-align)] 122 | #:indent [indent (current-item-indent)] 123 | #:fill? [fill? (current-para-fill?)] 124 | #:decode? [decode? #t] 125 | #:color [color (current-text-color)] 126 | . elements) 127 | (define bullet (htl-append (blank indent 0) (elem "→") (blank (em 0.75) 0))) 128 | (htl-append bullet 129 | (apply para #:width (- width (pict-width bullet)) 130 | #:align align #:fill? fill? #:decode? decode? elements))) 131 | 132 | (define (resolve-para-spacing [spacing (current-para-spacing)]) 133 | (match spacing 134 | [(? real?) spacing] 135 | [(list 'lines n) (* (current-font-size) n)])) 136 | 137 | (define (paras #:align [align (current-para-align)] 138 | #:spacing [spacing (current-para-spacing)] 139 | #:stage [stage #f] 140 | . elements) 141 | (apply (match align 142 | ['left vl-append] 143 | ['center vc-append] 144 | ['right vr-append]) 145 | (resolve-para-spacing spacing) 146 | (for/list ([element (in-list elements)] 147 | [i (in-naturals)]) 148 | (pict-when (or (not stage) (< i stage)) element)))) 149 | -------------------------------------------------------------------------------- /2022-11-haskell-exchange/lib/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | racket/function 5 | racket/math 6 | syntax/parse/define 7 | threading) 8 | 9 | (provide when~> 10 | (contract-out [make-lazy-parameter (-> any/c parameter?)] 11 | [lazy-parameter/c (->* [contract?] [contract?] contract?)] 12 | [turns (-> real? real?)])) 13 | 14 | (define (make-lazy-parameter val) 15 | (make-derived-parameter (make-parameter val) 16 | identity 17 | (λ (v) (if (procedure? v) (v) v)))) 18 | 19 | (define (lazy-parameter/c in-ctc [out-ctc in-ctc]) 20 | (parameter/c (or/c in-ctc (-> in-ctc)) out-ctc)) 21 | 22 | (define-simple-macro (when~> e:expr c:expr s:expr ...) 23 | (let ([v e]) (if c (~> v s ...) v))) 24 | 25 | (define (turns n) (* 2 pi n)) 26 | -------------------------------------------------------------------------------- /2022-11-haskell-exchange/main.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp slideshow 2 | 3 | (require (for-syntax racket/match 4 | syntax/parse/experimental/template) 5 | pict/conditional 6 | pict/shadow 7 | ppict/align 8 | ppict/tag 9 | racket/draw 10 | racket/runtime-path 11 | racket/sandbox 12 | rsvg 13 | slideshow/code 14 | slideshow/text 15 | scribble/example 16 | syntax/parse/define 17 | threading 18 | 19 | (prefix-in racket: racket/base) 20 | (prefix-in slideshow: slideshow/base) 21 | (only-in slideshow [current-font-size current-text-size]) 22 | 23 | "lib/color.rkt" 24 | "lib/pict.rkt" 25 | "lib/slideshow.rkt" 26 | "lib/util.rkt") 27 | 28 | (begin 29 | (define-runtime-path tweag.svg "assets/tweag.svg") 30 | (define-runtime-path mercury-icon.svg "assets/mercury-icon.svg") 31 | (define-runtime-path mercury-text.svg "assets/mercury-text.svg") 32 | (define-runtime-path screenshot-issue-21700-th-linking.png "assets/screenshot-issue-21700-th-linking.png") 33 | (define-runtime-path screenshot-mr-7502-fat-interface-files.png "assets/screenshot-mr-7502-fat-interface-files.png") 34 | (define-runtime-path screenshot-issue-bytecode-1.png "assets/screenshot-issue-bytecode-1.png") 35 | (define-runtime-path screenshot-issue-bytecode-2.png "assets/screenshot-issue-bytecode-2.png") 36 | (define-runtime-path screenshot-issue-bytecode-3.png "assets/screenshot-issue-bytecode-3.png") 37 | (define-runtime-path screenshot-issue-21853-codegen-printer.png "assets/screenshot-issue-21853-codegen-printer.png") 38 | 39 | (define tweag-logo 40 | (~> (rsvg-isolate (svg-file->pict tweag.svg)) 41 | (scale-to-fit 100 +inf.0))) 42 | (define mercury-logo 43 | (~> (hc-append (rsvg-isolate (svg-file->pict mercury-icon.svg)) 44 | (blank 10 0) 45 | (rsvg-isolate (svg-file->pict mercury-text.svg))) 46 | (scale-to-fit 95 +inf.0)))) 47 | 48 | ;; --------------------------------------------------------------------------------------------------- 49 | 50 | (define section (make-parameter #f)) 51 | 52 | (current-main-font "Concourse T3") 53 | (current-code-font '((weight . 500) . "Fira Code")) 54 | (current-text-size 40) 55 | (get-current-code-font-size 56 | (thunk (round (* (current-text-size) 9/10)))) 57 | 58 | (define transparent (make-color 0 0 0 0)) 59 | (define background-color (make-color #xf9 #xf9 #xf9)) 60 | (define code-background-color (make-color #xFA #xE9 #xE6)) 61 | (define code-border-color (make-color #xE8 #xCC #xC8)) 62 | (define text-plain-color (make-color #x40 #x40 #x40)) 63 | (define text-secondary-color (make-color #x60 #x60 #x60)) 64 | (define text-tertiary-color (make-color #xa0 #xa0 #xa0)) 65 | (define tertiary-color (make-color #xc0 #xc0 #xc0)) 66 | (define text-secondary-highlight-color (make-color #xb5 #xd0 #xff)) 67 | (define text-tertiary-highlight-color (make-color #xc7 #xff #xcd)) 68 | (define text-error-color (make-color #x8a #x16 #x16)) 69 | (define interaction-output-color (make-color #x96 #x00 #x96)) 70 | (define interaction-result-color (->color% (hsv 23/36 0.77 0.74))) 71 | (define shadow-color (make-color #x70 #x30 #x30)) 72 | 73 | (define shape-bg-color (make-color #xf7 #xf7 #xf7)) 74 | (define shape-border-color (make-color #xd8 #xd8 #xd8)) 75 | 76 | (current-highlight-color (make-color #xff #xd4 #xd1)) 77 | 78 | (current-text-color text-plain-color) 79 | (current-base-color text-tertiary-color) 80 | (current-keyword-color text-plain-color) 81 | (current-id-color (make-color #x37 #x50 #x73)) 82 | (current-literal-color (make-color #x87 #x4f #x37)) 83 | (current-comment-color (make-color #x9E #x55 #x55)) 84 | (define current-constructor-color (make-parameter (make-color #x59 #x37 #x73))) 85 | (let ([super (current-token-class->color)]) 86 | (current-token-class->color 87 | (λ (c) (case c 88 | [(constructor) (current-constructor-color)] 89 | [else (super c)])))) 90 | 91 | (define (c:plain p) (colorize p text-plain-color)) 92 | 93 | ;; --------------------------------------------------------------------------------------------------- 94 | 95 | (define-syntax-parser #%top 96 | [(_ . id:id) 97 | #:do [(define tag-name 98 | (match (symbol->string (syntax-e #'id)) 99 | [(regexp #px"^t:(.+)$" (list _ tag-name)) tag-name] 100 | [_ #f]))] 101 | #:when tag-name 102 | (quasisyntax/loc #'id 103 | (tag* '#,(string->symbol tag-name)))] 104 | [(_ . id) (quasisyntax/loc this-syntax (racket:#%top . id))]) 105 | 106 | (define c:highlights (make-parameter '())) 107 | 108 | (struct tagged (tag values) #:transparent) 109 | (define (tag t . vs) 110 | (match vs 111 | [(list (? pict? p)) (highlight-if (memq t (c:highlights)) (tag-pict p t))] 112 | [_ (tagged t vs)])) 113 | (define ((tag* t) . vs) 114 | (apply tag t vs)) 115 | 116 | ;; --------------------------------------------------------------------------------------------------- 117 | 118 | (set-margin! 20) 119 | (set-title-h! 80) 120 | (current-slide-assembler (make-scaling-slide-assembler #:background-color background-color)) 121 | 122 | (current-titlet 123 | (λ (s) (parameterize ([current-main-font "Concourse C3"]) 124 | (colorize (t (string-downcase s)) text-plain-color)))) 125 | 126 | ;; --------------------------------------------------------------------------------------------------- 127 | 128 | (define slides-prompt-tag (make-continuation-prompt-tag 'slides)) 129 | (define current-slide-render (make-parameter (thunk (error 'current-slide-render "no slide renderer")))) 130 | 131 | (struct slide-info (title body skippable?) #:transparent 132 | #:guard (struct-guard/c (or/c string? pict? #f) pict? any/c)) 133 | 134 | (define (call-with-slide-renderer render-thunk body-thunk #:title [title #f]) 135 | (define skipped 0) 136 | (parameterize ([current-slide-render render-thunk]) 137 | (let loop ([continue-thunk body-thunk]) 138 | (call-with-continuation-prompt 139 | continue-thunk slides-prompt-tag 140 | (λ (info continue) 141 | (cond 142 | [(and condense? (slide-info-skippable? info)) 143 | (set! skipped (add1 skipped)) 144 | (loop continue)] 145 | [else 146 | ; add a bunch of 'nexts to the slide to tell slideshow that some slides were dropped, 147 | ; which will cause it to display a range for the slide number 148 | (apply slide (append (make-list skipped 'next) (list (slide-info-body info))) 149 | #:title (slide-info-title info) 150 | #:name (section) 151 | #:layout 'top) 152 | (set! skipped 0) 153 | (loop continue)]))))) 154 | (skip-slides skipped)) 155 | 156 | (define (add-slide! info) 157 | (call-with-composable-continuation 158 | (λ (continue) (abort-current-continuation slides-prompt-tag 159 | info 160 | (thunk (continue (void))))) 161 | slides-prompt-tag)) 162 | 163 | (define (render-slide! #:skippable? skippable?) 164 | (define-values [title body] ((current-slide-render))) 165 | (add-slide! (slide-info title body (and skippable? #t)))) 166 | (define (next) (render-slide! #:skippable? #t)) 167 | (define (next!) (render-slide! #:skippable? #f)) 168 | 169 | (define-syntax-parser slides 170 | [(_ ({~describe "binding pair" [x:id e:expr]} ...) 171 | {~alt {~seq #:with param:expr param-val:expr} 172 | {~optional {~seq #:title title-e:expr}} 173 | {~once {~var render-e (expr/c #'pict? #:name "render expression")}} 174 | {~optional {~seq #:timeline timeline-body:expr ...+}} 175 | {~optional {~and #:condense-last {~bind [condense-last? #t]}}}} 176 | ... 177 | {~optional {~seq #:where ~! where-body:expr ...}}) 178 | 179 | (define stx this-syntax) 180 | (define-template-metafunction maybe-tl:last! 181 | (syntax-parser 182 | [(_ body ...) (if (attribute condense-last?) 183 | (syntax/loc stx (let () body ...)) 184 | (syntax/loc stx (tl:last! body ...)))])) 185 | 186 | (quasisyntax/loc this-syntax 187 | (let ([x (make-parameter e)] ...) 188 | (parameterize ([c:highlights (c:highlights)] 189 | [param param-val] ...) 190 | (call-with-slide-renderer 191 | #,(syntax/loc #'render-e (thunk {~? {~@ where-body ...}} (values {~? title-e #f} render-e))) 192 | #,(syntax/loc this-syntax (thunk {~? (maybe-tl:last! {~@ timeline-body ...}) (next!)} (void)))))))]) 193 | 194 | ;; --------------------------------------------------------------------------------------------------- 195 | 196 | (define (tl:last!/proc continue) 197 | (define prev #f) 198 | (begin0 199 | (let loop ([continue continue]) 200 | (call-with-continuation-prompt 201 | continue slides-prompt-tag 202 | (λ (info continue) 203 | (when prev (add-slide! prev)) 204 | (set! prev info) 205 | (loop continue)))) 206 | (if prev 207 | (add-slide! (struct-copy slide-info prev [skippable? #f])) 208 | (error 'tl:last! "timeline did not yield")))) 209 | 210 | (define-simple-macro (tl:last! body ...+) 211 | (tl:last!/proc (thunk body ...))) 212 | 213 | (define (tl:sequence param seq) 214 | (for ([v seq]) 215 | (param v) 216 | (next))) 217 | 218 | (define (tl:flags #:set [val #t] . params) 219 | (for ([param (in-list params)]) 220 | (param val) 221 | (next))) 222 | 223 | (define (tl:show . params) 224 | (apply tl:flags #:set show params)) 225 | 226 | (define (tl:highlight+ . whichs) 227 | (for ([which (in-list whichs)]) 228 | (if (list? which) 229 | (c:highlights (append which (c:highlights))) 230 | (c:highlights (cons which (c:highlights)))) 231 | (next))) 232 | 233 | ;; --------------------------------------------------------------------------------------------------- 234 | 235 | (define (ol #:sep [sep (em 4/5)] 236 | #:spacing [spacing (current-para-spacing)] 237 | #:stage [stage #f] 238 | . elems) 239 | (define num-picts (parameterize ([current-main-font "Concourse Index"]) 240 | (for/list ([i (in-range (length elems))]) 241 | (c:plain (t (~a (add1 i))))))) 242 | (define max-num-width (apply max (map pict-width num-picts))) 243 | (~>> (for/list ([elem (in-list elems)] 244 | [num (in-list num-picts)]) 245 | (htl-append sep (indent #:by (- max-num-width (pict-width num)) num) elem)) 246 | (apply paras #:spacing spacing #:stage stage))) 247 | 248 | (define (box w h 249 | #:highlight? [highlight? #f] 250 | #:border-width [border-width 2]) 251 | (filled-rectangle w h 252 | #:color (if highlight? (current-highlight-color) shape-bg-color) 253 | #:border-width border-width 254 | #:border-color (if highlight? (current-highlight-border-color) shape-border-color))) 255 | 256 | (define (wrap-box p #:padding [padding 15]) 257 | (cc-superimpose (box (+ (pict-width p) (* padding 2)) 258 | (+ (pict-height p) (* padding 2))) 259 | p)) 260 | 261 | (define (encircle p 262 | #:padding [padding 15] 263 | #:highlight? [highlight? #f] 264 | #:color [color (if highlight? (current-highlight-color) shape-bg-color)] 265 | #:border-color [border-color (if highlight? (current-highlight-border-color) shape-border-color)] 266 | #:border-width [border-width 2]) 267 | (~> (disk (+ (max (pict-width p) (pict-height p)) 268 | (* (+ padding (/ border-width 2)) 2)) 269 | #:color color 270 | #:border-width border-width 271 | #:border-color border-color) 272 | (cc-superimpose p))) 273 | 274 | (define (p:file p 275 | #:color [color shape-bg-color] 276 | #:border-color [border-color shape-border-color]) 277 | (cc-superimpose (~> (file-icon 40 50) 278 | (adjust-pen #:color border-color 279 | #:width 1.25 280 | #:cap 'projecting 281 | #:join 'miter) 282 | (colorize color)) 283 | (~> (scale-to-fit p 25 35) 284 | (colorize text-secondary-color)))) 285 | 286 | (define terminal-text-color (->color% (hsv 0 0 0.93))) 287 | (define terminal-bg-color (->color% (hsv 0 0 0.2))) 288 | (define terminal-highlight-color (->color% (hsv 0 0.3 0.4))) 289 | (define (wrap-terminal-frame p #:padding [padding 20]) 290 | (cc-superimpose 291 | (filled-rounded-rectangle (+ (pict-width p) (* padding 2)) 292 | (+ (pict-height p) (* padding 2)) 293 | 15 294 | #:draw-border? #f 295 | #:color terminal-bg-color) 296 | (colorize p terminal-text-color))) 297 | 298 | ;; --------------------------------------------------------------------------------------------------- 299 | 300 | (section "Title") 301 | 302 | (slides () 303 | (~> (vc-append title 304 | (~> (filled-rectangle (+ (pict-width title) 40) 1 #:draw-border? #f) 305 | (inset 0 -5 0 15)) 306 | (with-size 30 307 | (hflex (+ (pict-width title) 20) 308 | (t "Alexis King") (spring 1) (t "Tweag"))) 309 | (blank 0 50)) 310 | (colorize text-secondary-color)) 311 | #:where 312 | (define title (~> (with-size 100 313 | (with-font "Concourse C2" 314 | @t{Towards a Faster GHC})) 315 | (colorize text-plain-color)))) 316 | 317 | (begin 318 | (slides ([s:header? #f] [s:bullet 0]) 319 | #:timeline (next) (tl:flags s:header?) (tl:sequence s:bullet (in-range 1 4)) 320 | #:with current-para-spacing '(lines 0.5) 321 | #:with current-para-width 700 322 | (vc-append 323 | (pict-when (s:header?) 324 | (scale @elem{“GHC is slow.”} 2)) 325 | (blank 0 40) 326 | (paras #:stage (s:bullet) 327 | @item{GHC does a lot of stuff!} 328 | @item{GHC@it{has} been optimized.} 329 | @item{Finding new improvements is hard.}) 330 | (blank 0 60))) 331 | 332 | (slides ([s:bullet 0]) 333 | #:timeline (tl:sequence s:bullet 4) 334 | #:with current-para-spacing '(lines 0.5) 335 | (vc-append 336 | (inset (scale mercury-logo 7) 0 0 20 0) 337 | (blank 0 70) 338 | (paras #:stage (s:bullet) 339 | @item{Almost 4,000 Haskell source modules.} 340 | @item{Easily 5+ minute cold build times, even with@tt{-O0} and @tt{-j}.} 341 | @item{Even longer deploy times with@tt{-O2}.}))) 342 | 343 | (slides () 344 | (~> (vc-append mercury-logo 345 | (blank 0 -2) 346 | (scale (elem "&") 0.3) 347 | (blank 0 5) 348 | tweag-logo 349 | (blank 0 15)) 350 | (inset 10 0))) 351 | 352 | (slides () 353 | (inset @titlet{Progress Report} 30)) 354 | 355 | (slides () 356 | (~> (bitmap screenshot-issue-21700-th-linking.png) 357 | (shadow-frame #:margin 0 #:shadow-descent 20))) 358 | 359 | (slides ([s:bullet 0]) 360 | #:timeline (tl:sequence s:bullet 5) 361 | #:with current-para-spacing '(lines 0.8) 362 | #:title "Some Context" 363 | (vc-append (paras #:stage (s:bullet) 364 | @item{Mercury’s code uses lots of Template Haskell for deriving typeclass instances.} 365 | @item{Folk wisdom is that TH is slow, but why?} 366 | @item{Evaluating TH splices themselves is relatively cheap.} 367 | @item{Turns out: most the time is spent in the linker, not GHC!}) 368 | (blank 0 100))) 369 | 370 | (slides ([s:bullet 0]) 371 | #:timeline (tl:sequence s:bullet 5) 372 | #:with current-para-spacing '(lines 0.6) 373 | #:with current-para-width 1100 374 | (vc-append 375 | (scale @elem{Linking is a headache.} 1.7) 376 | (blank 0 60) 377 | (paras #:stage (s:bullet) 378 | @item{TH needs to load code from other modules.} 379 | @item{Loading code uses the system dynamic linker.} 380 | @item{The system dynamic linker can only load@it{libraries}, not objects.} 381 | @item{Linking libraries on-demand has@it{seconds-long} linking times!}) 382 | (blank 0 100))) 383 | 384 | (slides ([s:solution? #f]) 385 | #:timeline (next) (tl:flags s:solution?) 386 | (inset 387 | (vc-append 388 | @elem{“The only winning move is not to play.”} 389 | (blank 40) 390 | (pict-when (s:solution?) 391 | (scale @elem{Solution: the bytecode compiler.} 1.3)) 392 | (blank 60)) 393 | 20)) 394 | 395 | (slides () 396 | (~> (bitmap screenshot-mr-7502-fat-interface-files.png) 397 | (shadow-frame #:margin 0 #:shadow-descent 20))) 398 | 399 | (slides ([s:bullet 0]) 400 | #:timeline (tl:sequence s:bullet 6) 401 | #:title "Quick Summary" 402 | #:with current-para-spacing '(lines 0.8) 403 | #:with current-para-width 1400 404 | (vc-append 405 | (paras #:stage (s:bullet) 406 | @item{A set of new code generation options in GHC 9.6, implemented by Matthew Pickering.} 407 | @item{Pass@tt{-fwrite-if-simplfied-core},@tt{-fbyte-code-and-object-code}, and@tt{-fprefer-byte-code} for the full benefit.} 408 | @item{GHC will generate bytecode from Core as-needed for Template Haskell.} 409 | @item{For Mercury’s codebase, a nearly 60% build time improvement with@tt{-O0}!} 410 | @item{…does not yet work properly with@tt{-O1}.}) 411 | (blank 0 100))) 412 | 413 | (slides () 414 | (~> (list (bitmap screenshot-issue-bytecode-1.png) 415 | (bitmap screenshot-issue-bytecode-2.png) 416 | (bitmap screenshot-issue-bytecode-3.png)) 417 | (map (λ~> (shadow-frame #:shadow-descent 20)) _) 418 | (apply vc-append _))) 419 | 420 | (slides ([s:bullet 0]) 421 | #:timeline (tl:sequence s:bullet 5) 422 | #:title "Modernizing the Bytecode Compiler" 423 | #:with current-para-spacing '(lines 0.6) 424 | (vc-append 425 | (paras #:stage (s:bullet) 426 | @item{The bytecode compiler was designed for GHCi.} 427 | @item{Now used in many other places, including TH.} 428 | @item{Not many experts on the bytecode compiler.} 429 | @item{Goal: bytecode should be usable with@tt{-O} by GHC 9.8.}) 430 | (blank 0 100))) 431 | 432 | (slides () 433 | (inset (vc-append @titlet{Codegen Printer} 434 | (blank 0 -8) 435 | @titlet{Optimizations}) 436 | 50)) 437 | 438 | (slides ([s:bullet 0]) 439 | #:timeline (tl:sequence s:bullet 5) 440 | #:with current-para-spacing '(lines 0.6) 441 | (vc-append 442 | (paras #:stage (s:bullet) 443 | @item{In most build configurations, GHC uses its own native code generator (NCG).} 444 | @item{GHC uses the system assembler to assemble native code.} 445 | @item{In practice, GHC spends a surprising amount of time printing assembly.} 446 | @item{In some extreme cases, ~15% of time and ~17% of allocations could be spent printing!}) 447 | (blank 0 100))) 448 | 449 | (slides () 450 | (~> (bitmap screenshot-issue-21853-codegen-printer.png) 451 | (shadow-frame #:margin 0 #:shadow-descent 20))) 452 | 453 | (slides ([s:bullet 0]) 454 | #:timeline (tl:sequence s:bullet 5) 455 | #:title "New Codegen Printer" 456 | #:with current-para-spacing '(lines 0.7) 457 | #:with current-para-width 1300 458 | (vc-append 459 | (paras #:stage (s:bullet) 460 | @item{New, targeted implementation of the codegen printer (by Krzysztof Gogolewski and myself) in GHC 9.6.} 461 | @item{On average, seems to provide a 2–3% reduction in compile times and a 5–10% reduction in allocations, when compiled with@tt{-O0}.} 462 | @item{Benefits essentially all build configurations, but gains are proportionally smaller for optimized builds.} 463 | @item{In-depth blog post will be published on the Tweag blog in coming weeks.}) 464 | (blank 0 130))) 465 | 466 | (slides ([s:bullet 0] [s:thanks? #f]) 467 | #:timeline (tl:sequence s:bullet 6) (tl:flags s:thanks?) 468 | #:title "Closing Thoughts" 469 | #:with current-para-spacing '(lines 0.6) 470 | #:with current-para-width 1300 471 | (vc-append 472 | (paras #:stage (s:bullet) 473 | @item{Recap: TH and codegen performance improvements coming to GHC 9.6.} 474 | (indent #:by (em 2) @item{Further bytecode compiler improvements coming to GHC 9.8.}) 475 | @item{Many thanks again to Mercury for funding this work!} 476 | @item{Next steps: the typechecker and optimizer?} 477 | @item{Please come talk to us while you’re here if you’d like to learn more!}) 478 | (blank 0 40) 479 | (pict-when (s:thanks?) 480 | (scale @elem{Thanks!} 2)) 481 | (blank 0 80)))) 482 | 483 | (start-at-recent-slide) 484 | -------------------------------------------------------------------------------- /2023-06-delimited-continuations/Makefile: -------------------------------------------------------------------------------- 1 | COMPILE := 2 | CPUS := $(shell racket -e '(display (processor-count))') 3 | RACKET_VERSION := $(shell racket -e '(display (version))') 4 | 5 | LIB_SRCS := color.rkt pict.rkt slideshow.rkt unicode.rkt util.rkt 6 | ASSET_SRCS := 7 | 8 | ZO_PREFIX := compiled/$(RACKET_VERSION)/compiled 9 | LIB_ZOS := $(LIB_SRCS:%.rkt=lib/$(ZO_PREFIX)/%_rkt.zo) 10 | 11 | SLIDESHOW_OPTS := --pdf --not-paper --widescreen --zero-margins --no-stretch \ 12 | --no-resize --progress-text 13 | 14 | SLIDES_DEPS := main.rkt $(addprefix assets/,$(ASSET_SRCS)) 15 | ifdef COMPILE 16 | SLIDES_DEPS += compile 17 | else 18 | SLIDES_DEPS += $(LIB_ZOS) 19 | endif 20 | 21 | all: slides.pdf slides-uncondensed.pdf 22 | 23 | slides.pdf: $(SLIDES_DEPS) 24 | slideshow $(SLIDESHOW_OPTS) --condense -o slides.pdf main.rkt 25 | slides-uncondensed.pdf: $(SLIDES_DEPS) 26 | slideshow $(SLIDESHOW_OPTS) -o slides-uncondensed.pdf main.rkt 27 | 28 | lib/$(ZO_PREFIX)/slideshow_rkt.zo: lib/$(ZO_PREFIX)/pict_rkt.zo lib/$(ZO_PREFIX)/util_rkt.zo 29 | 30 | %_rkt.zo: ../../../%.rkt 31 | raco make $< 32 | 33 | compile: main.rkt $(addprefix lib/,$(LIB_SRCS)) 34 | raco make -v -j '$(CPUS)' main.rkt 35 | 36 | watch: 37 | @watch-exec --bell -p main.rkt $(addprefix -p lib/,$(LIB_SRCS)) -- \ 38 | '$(MAKE)' -j '$(CPUS)' CPUS='$(CPUS)' RACKET_VERSION='$(RACKET_VERSION)' 39 | 40 | .PHONY: all compile watch 41 | -------------------------------------------------------------------------------- /2023-06-delimited-continuations/assets/haskell-logo.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /2023-06-delimited-continuations/assets/tweag.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /2023-06-delimited-continuations/lib/color.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/struct-info) 5 | racket/class 6 | racket/contract 7 | racket/draw 8 | racket/match 9 | threading) 10 | 11 | (provide (rename-out [rgb* rgb] [hsv* hsv]) 12 | rgb-red rgb-green rgb-blue rgb-alpha 13 | hsv-hue hsv-saturation hsv-value hsv-alpha 14 | 15 | (contract-out 16 | [color? predicate/c] 17 | [->color% (-> color? (is-a?/c color%))] 18 | [->rgb (-> color? rgb?)] 19 | [->hsv (-> color? hsv?)] 20 | 21 | [scale-color-value (-> color? (>=/c 0) color?)] 22 | [add-color-value (-> color? real? color?)])) 23 | 24 | ;; ----------------------------------------------------------------------------- 25 | 26 | (define (fmod x n) 27 | (define i (floor x)) 28 | (+ (remainder i n) (- x i))) 29 | 30 | (struct rgb (red green blue alpha) #:transparent 31 | #:guard (struct-guard/c (real-in 0 1) (real-in 0 1) (real-in 0 1) (real-in 0 1))) 32 | (struct hsv (hue saturation value alpha) #:transparent 33 | #:guard (struct-guard/c (real-in 0 1) (real-in 0 1) (real-in 0 1) (real-in 0 1))) 34 | 35 | (define (make-rgb r g b [alpha 1.0]) 36 | (rgb r g b alpha)) 37 | (define (make-hsv h s v [alpha 1.0]) 38 | (define h* (- h (truncate h))) 39 | (hsv (if (< h* 0.0) (+ 1.0 h*) h*) s v alpha)) 40 | 41 | (begin-for-syntax 42 | (struct struct-info (ctor-id list field-syms) #:transparent 43 | #:property prop:struct-info (λ (self) (struct-info-list self)) 44 | #:property prop:struct-field-info (λ (self) (struct-info-field-syms self)) 45 | #:property prop:expansion-contexts '(expression) 46 | #:property prop:procedure 47 | (λ (self stx) 48 | (define ctor-id (struct-info-ctor-id self)) 49 | (syntax-case stx () 50 | [id (identifier? #'id) ctor-id] 51 | [(_ . args) (datum->syntax stx (cons ctor-id #'args) stx)]))) 52 | (define (make-custom-ctor-struct-info base-id ctor-id) 53 | (define base-info (syntax-local-value base-id)) 54 | (define base-list (extract-struct-info base-info)) 55 | (define base-fields (struct-field-info-list base-info)) 56 | (struct-info ctor-id 57 | (list* (car base-list) ctor-id (cddr base-list)) 58 | base-fields))) 59 | 60 | (define-syntax rgb* (make-custom-ctor-struct-info #'rgb #'make-rgb)) 61 | (define-syntax hsv* (make-custom-ctor-struct-info #'hsv #'make-hsv)) 62 | 63 | (define (hsv->rgb h s v [alpha 1.0]) 64 | (define (f n) 65 | (define k (fmod (+ n (* h 6.0)) 6)) 66 | (- v (* v s (max 0.0 (min k (- 4.0 k) 1.0))))) 67 | (rgb (f 5.0) (f 3.0) (f 1.0) alpha)) 68 | 69 | (define (rgb->hsv r g b [alpha 1.0]) 70 | (define v (max r g b)) 71 | (define chroma (- v (min r g b))) 72 | (define h (cond 73 | [(zero? chroma) 0.0] 74 | [(= v r) (/ (/ (- g b) chroma) 6.0)] 75 | [(= v g) (/ (+ 2.0 (/ (- b r) chroma)) 6.0)] 76 | [else (/ (+ 4.0 (/ (- r g) chroma)) 6.0)])) 77 | (define s (if (zero? chroma) 0 (/ chroma v))) 78 | (hsv h s v alpha)) 79 | 80 | ;; ----------------------------------------------------------------------------- 81 | 82 | (define (color? v) 83 | (or (is-a? v color%) 84 | (rgb? v) 85 | (hsv? v) 86 | (and (string? v) 87 | (send the-color-database find-color v) 88 | #t))) 89 | 90 | (define (find-color% who name) 91 | (or (send the-color-database find-color name) 92 | (raise-arguments-error who "no known color with name" "name" name))) 93 | 94 | (define (->color% v) 95 | (match v 96 | [(? (λ~> (is-a? color%))) v] 97 | [(rgb r g b a) 98 | (define (f n) (inexact->exact (round (max 0 (min (* n 255) 255))))) 99 | (make-color (f r) (f g) (f b) a)] 100 | [(hsv h s v a) 101 | (->color% (hsv->rgb h s v a))] 102 | [(? string?) 103 | (find-color% '->color% v)])) 104 | 105 | (define (->rgb v) 106 | (match v 107 | [(? rgb?) v] 108 | [(? (λ~> (is-a? color%))) 109 | (rgb (/ (send v red) 255.0) 110 | (/ (send v green) 255.0) 111 | (/ (send v blue) 255.0) 112 | (send v alpha))] 113 | [(hsv h s v a) 114 | (hsv->rgb h s v a)] 115 | [(? string?) 116 | (->rgb (find-color% '->rgb v))])) 117 | 118 | (define (->hsv v) 119 | (match v 120 | [(? hsv?) v] 121 | [(? (λ~> (is-a? color%))) 122 | (rgb->hsv (/ (send v red) 255.0) 123 | (/ (send v green) 255.0) 124 | (/ (send v blue) 255.0) 125 | (send v alpha))] 126 | [(rgb r g b a) 127 | (rgb->hsv r g b a)] 128 | [(? string?) 129 | (->hsv (find-color% '->hsv v))])) 130 | 131 | ;; ----------------------------------------------------------------------------- 132 | 133 | (define (scale-color-value color fac) 134 | (match-define (hsv h s v a) (->hsv color)) 135 | (hsv h s (min (* v fac) 1) a)) 136 | 137 | (define (add-color-value color amt) 138 | (match-define (hsv h s v a) (->hsv color)) 139 | (hsv h s (max 0 (min (+ v amt) 1)) a)) 140 | -------------------------------------------------------------------------------- /2023-06-delimited-continuations/lib/pict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require pict 4 | (only-in pict 5 | [pin-over pict:pin-over] 6 | [pin-under pict:pin-under]) 7 | pict/conditional 8 | ppict/align 9 | ppict/tag 10 | racket/class 11 | racket/contract 12 | racket/draw 13 | racket/list 14 | racket/match 15 | slideshow/base 16 | threading 17 | "color.rkt" 18 | "util.rkt") 19 | 20 | (provide (contract-out [pict-color/c flat-contract?] 21 | [pict-finder/c chaperone-contract?] 22 | [ppath-cons (-> pict? (or/c pict-path? #f) pict-path?)] 23 | [adjust-find (-> pict-finder/c real? real? pict-finder/c)] 24 | 25 | [child-path? flat-contract?] 26 | [find-child (-> pict? child-path? pict-path?)] 27 | [find-children (-> pict? child-path? (listof pict-path?))] 28 | 29 | [pict-when (->* [any/c pict?] [#:launder? any/c] pict?)] 30 | [pict-unless (->* [any/c pict?] [#:launder? any/c] pict?)] 31 | [picts-take (-> (listof pict?) exact-nonnegative-integer? (listof pict?))] 32 | 33 | [current-highlight-color (parameter/c pict-color/c)] 34 | [current-highlight-bleed (parameter/c real?)] 35 | [current-highlight-border-color (lazy-parameter/c pict-color/c)] 36 | 37 | [line (-> real? real? pict?)] 38 | [wedge (-> real? real? real? real? pict?)] 39 | [arrow-line (->* [] [#:arrow-size real? 40 | #:line-length real? 41 | #:line-width real?] 42 | pict?)] 43 | [highlight (->* [pict?] 44 | [#:path child-path? 45 | #:bleed real? 46 | #:color pict-color/c 47 | #:bounds? any/c] 48 | pict?)] 49 | [file-icon (-> real? real? pict?)] 50 | 51 | [em (->* [] [real?] real?)] 52 | [one-line (-> pict? pict?)] 53 | [indent (->* [pict?] [#:by real?] pict?)] 54 | [pip (case-> (-> pict? pict-finder/c pict?) 55 | (-> pict? 56 | (or/c real? pict-path?) 57 | (or/c real? pict-finder/c) 58 | pict?))] 59 | [refocus* (-> pict? (non-empty-listof pict?) pict?)] 60 | [recenter (-> pict? real? real? pict?)] 61 | [recenter/tag (->* [pict? tag-path?] [pict-finder/c] pict?)] 62 | [set-ascent (-> pict? pict-finder/c child-path? pict?)] 63 | [set-descent (-> pict? pict-finder/c child-path? pict?)] 64 | 65 | [maybe-colorize (-> pict? (or/c pict-color/c #f) pict?)] 66 | [set-smoothing (-> pict? (or/c 'unsmoothed 'smoothed 'aligned) pict?)] 67 | [adjust-pen (->* [pict?] 68 | [#:color (or/c string? (is-a?/c color%) #f) 69 | #:width (or/c (real-in 0 255) #f) 70 | #:style (or/c pen-style/c #f) 71 | #:cap (or/c pen-cap-style/c #f) 72 | #:join (or/c pen-join-style/c #f)] 73 | pict?)] 74 | #;[cellophane (-> pict? (real-in 0 1) pict?)] 75 | [metrics-frame (-> pict? pict?)] 76 | [rsvg-isolate (-> pict? pict?)] 77 | 78 | [pin-over (->* [pict? 79 | (or/c real? child-path?) 80 | (or/c real? procedure?) 81 | pict?] 82 | [#:hole any/c] 83 | pict?)] 84 | [pin-under (->* [pict? 85 | (or/c real? child-path?) 86 | (or/c real? procedure?) 87 | pict?] 88 | [#:hole any/c] 89 | pict?)] 90 | [line-append (-> pict? pict? ... pict?)] 91 | (struct spring ([weight real?])) 92 | [hflex (->* [real?] 93 | [#:combine (-> pict? pict? ... pict?)] 94 | #:rest (non-empty-listof (or/c pict? spring?)) 95 | pict?)])) 96 | 97 | ;; ----------------------------------------------------------------------------- 98 | ;; miscellany 99 | 100 | (define pict-color/c (or/c string? (is-a?/c color%) (list/c byte? byte? byte?))) 101 | (define pict-finder/c (-> pict? pict-path? (values real? real?))) 102 | (define child-path? (or/c pict? symbol? (listof (or/c pict? symbol?)))) 103 | 104 | (define (ppath-cons p path) 105 | (match path 106 | [#f p] 107 | [(? list?) (cons p path)] 108 | [(? pict?) (list p path)])) 109 | 110 | (define (ppath-last path) 111 | (match path 112 | [#f #f] 113 | [(list _ ... p) p] 114 | [(? pict? p) p])) 115 | 116 | (define ((adjust-find find dx dy) p path) 117 | (define-values [x y] (find p path)) 118 | (values (+ x dx) (+ y dy))) 119 | 120 | (define (child-matches-path-elem? child elem) 121 | (if (pict? elem) 122 | (equal? child elem) 123 | (eq? (pict-tag child) elem))) 124 | 125 | (define (find-child p path) 126 | (let ([path (if (list? path) path (list path))]) 127 | (let/ec escape 128 | (let loop ([child p] 129 | [parents '()] 130 | [path path]) 131 | (match path 132 | ['() (escape (reverse (cons child parents)))] 133 | [(cons elem path*) 134 | (if (child-matches-path-elem? child elem) 135 | (loop child parents path*) 136 | (for ([child* (in-list (pict-children child))]) 137 | (loop (child-pict child*) (cons child parents) path)))])) 138 | (raise-arguments-error 'find-child "no sub-pict with the given path" 139 | "pict" p 140 | "path" path)))) 141 | 142 | (define (find-children p path) 143 | (let ([path (if (list? path) path (list path))]) 144 | (let loop ([child p] 145 | [parents '()] 146 | [path path]) 147 | (match path 148 | ['() (list (reverse (cons child parents)))] 149 | [(cons elem path*) 150 | (if (child-matches-path-elem? child elem) 151 | (loop child parents path*) 152 | (append-map 153 | (λ (child*) 154 | (loop (child-pict child*) (cons child parents) path)) 155 | (pict-children child)))])))) 156 | 157 | (define (find-children-bounds p path) 158 | (define children (find-children p path)) 159 | (match (find-children p path) 160 | ['() #f] 161 | [(cons child-path child-paths) 162 | (define-values [x-min y-min] (lt-find p child-path)) 163 | (define-values [x-max y-max] (rb-find p child-path)) 164 | (for/fold ([x-min x-min] 165 | [y-min y-min] 166 | [x-max x-max] 167 | [y-max y-max] 168 | #:result (vector-immutable x-min y-min (- x-max x-min) (- y-max y-min))) 169 | ([child-path (in-list child-paths)]) 170 | (define-values [x-min* y-min*] (lt-find p child-path)) 171 | (define-values [x-max* y-max*] (rb-find p child-path)) 172 | (values (min x-min x-min*) 173 | (min y-min y-min*) 174 | (max x-max x-max*) 175 | (max y-max y-max*)))])) 176 | 177 | ;; ----------------------------------------------------------------------------- 178 | ;; conditionals 179 | 180 | (define (pict-when test then #:launder? [launder? #f]) 181 | (if test then (~> (ghost then) (when~> launder? launder)))) 182 | (define (pict-unless test then #:launder? [launder? #f]) 183 | (if test (~> (ghost then) (when~> launder? launder)) then)) 184 | 185 | (define (picts-take ps n) 186 | (for/list ([p (in-list ps)] 187 | [i (in-naturals)]) 188 | (if (< i n) p (ghost p)))) 189 | 190 | ;; ----------------------------------------------------------------------------- 191 | ;; parameters 192 | 193 | (define current-highlight-color (make-parameter (make-color #xFF #xB9 #xB5))) 194 | (define current-highlight-bleed (make-parameter 6)) 195 | 196 | (define current-highlight-border-color 197 | (make-lazy-parameter 198 | (λ () 199 | (->color% (scale-color-value (current-highlight-color) 0.8))))) 200 | 201 | ;; ----------------------------------------------------------------------------- 202 | ;; constructors 203 | 204 | (define (line dx dy) 205 | (dc (λ (dc x y) (send dc draw-line x y (+ x dx) (+ y dy))) dx dy)) 206 | 207 | (define p:center (blank)) 208 | 209 | (define (wedge w h start-radians end-radians) 210 | (dc (λ (dc x y) 211 | (define old-pen (send dc get-pen)) 212 | (send dc set-pen (make-pen #:style 'transparent)) 213 | (send dc draw-arc x y w h start-radians end-radians) 214 | (send dc set-pen old-pen)) 215 | w h)) 216 | 217 | (define (arrow-line #:arrow-size [arrow-size 10] 218 | #:line-length [line-length 70] 219 | #:line-width [line-width 2]) 220 | (panorama (pin-over/align (linewidth line-width (hline line-length line-width)) 221 | line-length (/ line-width 2) 'c 'c 222 | (arrowhead arrow-size 0)))) 223 | 224 | (define (highlight p 225 | #:path [path '()] 226 | #:bleed [bleed (current-highlight-bleed)] 227 | #:color [color (current-highlight-color)] 228 | #:bounds? [bounds? #f]) 229 | (cond 230 | [bounds? 231 | (match (find-children-bounds p path) 232 | [#f p] 233 | [(vector x y w h) 234 | (pin-under p 235 | (- x bleed) 236 | (- y bleed) 237 | (filled-rectangle (+ w (* bleed 2)) 238 | (+ h (* bleed 2)) 239 | #:draw-border? #f 240 | #:color color))])] 241 | [else 242 | (define children (find-children p path)) 243 | (for/fold ([p* p]) 244 | ([child (in-list children)]) 245 | ;; To calculate the highlight height, we use the height of the 246 | ;; child *without* its descent, then center the result on the 247 | ;; entire child, including its descent. This is a complete hack, 248 | ;; but it seems to work well in practice when highlighting text, 249 | ;; as otherwise the highlights are too tall. 250 | (define-values [x-min y-min] (lt-find p child)) 251 | (define-values [x-bl y-bl] (cbl-find p child)) 252 | (define-values [x-max y-max] (rb-find p child)) 253 | (pin-under p* 254 | (- x-min bleed) 255 | (- (+ y-min (/ (- y-max y-bl) 2)) bleed) 256 | (filled-rectangle (+ (- x-max x-min) (* bleed 2)) 257 | (+ (- y-bl y-min) (* bleed 2)) 258 | #:draw-border? #f 259 | #:color color)))])) 260 | 261 | ; Adapted from pict. 262 | (define (file-icon w h) 263 | (dc (let* ([sw (lambda (x) (* (/ w 110) x))] 264 | [sh (lambda (y) (* (/ h 150) y))] 265 | [->pt (lambda (l) 266 | (map (lambda (p) 267 | (make-object point% 268 | (sw (car p)) 269 | (sh (cadr p)))) 270 | l))]) 271 | (lambda (dc x y) 272 | (send dc draw-polygon 273 | (->pt '((0 0) 274 | (0 150) 275 | (110 150) 276 | (110 20) 277 | (90 0))) 278 | x y) 279 | (send dc draw-line (+ x (sw 90)) (+ y 1) (+ x (sw 90)) (+ y (sh 20))) 280 | (send dc draw-line (+ x (sw 90)) (+ y (sh 20)) (+ x (sw 110) -1) (+ y (sh 20))))) 281 | w h)) 282 | 283 | ;; ----------------------------------------------------------------------------- 284 | ;; sizing / bounding box adjusters 285 | 286 | (define (em [n 1]) (* (pict-width (t "M")) n)) 287 | 288 | ; Drops the ascent line to the descent line, making the entire pict behave as a 289 | ; single line of text. 290 | (define (one-line p) 291 | (define ascent (- (pict-height p) (pict-descent p))) 292 | (pin-over (blank (pict-width p) (pict-height p) ascent (pict-descent p)) 0 0 p)) 293 | 294 | (define (indent #:by [n (em)] p) (inset p n 0 0 0)) 295 | 296 | ; Like `refocus` but shifts the bounding box to encompass all of a list of picts. 297 | (define (refocus* base-p sub-ps) 298 | (for/fold ([x1 +inf.0] 299 | [y1 +inf.0] 300 | [x2 -inf.0] 301 | [y2 -inf.0] 302 | #:result (pin-over (blank (- x2 x1) (- y2 y1)) (- x1) (- y1) base-p)) 303 | ([sub-p (in-list sub-ps)]) 304 | (define-values [sub-x1 sub-y1] (lt-find base-p sub-p)) 305 | (define-values [sub-x2 sub-y2] (rb-find base-p sub-p)) 306 | (values (min x1 sub-x1 sub-x2) 307 | (min y1 sub-y1 sub-y2) 308 | (max x2 sub-x1 sub-x2) 309 | (max y2 sub-y1 sub-y2)))) 310 | 311 | ; Convert the pict to a zero-sized pict centered at a particular location. 312 | (define pip 313 | (case-lambda 314 | [(p find) 315 | (pip p p find)] 316 | [(p a b) 317 | (define pinhole (blank)) 318 | (refocus (pin-over p a b pinhole) pinhole)])) 319 | 320 | ; Insets the given pict so that the given point is its center. 321 | (define (recenter p x y) 322 | (define h-inset (- (* x 2) (pict-width p))) 323 | (define v-inset (- (* y 2) (pict-height p))) 324 | (inset p 325 | (max 0 (- h-inset)) 326 | (max 0 (- v-inset)) 327 | (max 0 h-inset) 328 | (max 0 v-inset))) 329 | 330 | (define (recenter/tag p tag [find cc-find]) 331 | (define-values [x y] (find p (or (find-tag p tag) 332 | (raise-arguments-error 'recenter/tag "no sub-pict found with tag" "tag" tag)))) 333 | (recenter p x y)) 334 | 335 | (define (set-ascent p find path) 336 | (define-values [sub-x sub-y] (find p (find-child p path))) 337 | (struct-copy pict p [ascent sub-y])) 338 | 339 | (define (set-descent p find path) 340 | (define-values [sub-x sub-y] (find p (find-child p path))) 341 | (struct-copy pict p [descent (- (pict-height p) sub-y)])) 342 | 343 | ;; ----------------------------------------------------------------------------- 344 | ;; drawing adjusters 345 | 346 | (define (maybe-colorize p color) 347 | (if color (colorize p color) p)) 348 | 349 | (define (dc/wrap p proc) 350 | (define draw-p (make-pict-drawer p)) 351 | (struct-copy 352 | pict 353 | (dc (λ (dc dx dy) (proc draw-p dc dx dy)) 354 | (pict-width p) 355 | (pict-height p) 356 | (pict-ascent p) 357 | (pict-descent p)) 358 | [children (list (make-child p 0 0 1 1 0 0))] 359 | [last (pict-last p)])) 360 | 361 | (define (set-smoothing p smoothing) 362 | (define draw-p (make-pict-drawer p)) 363 | (struct-copy 364 | pict 365 | (dc (λ (dc dx dy) 366 | (define old-smoothing (send dc get-smoothing)) 367 | (send dc set-smoothing smoothing) 368 | (draw-p dc dx dy) 369 | (send dc set-smoothing old-smoothing)) 370 | (pict-width p) 371 | (pict-height p) 372 | (pict-ascent p) 373 | (pict-descent p)) 374 | [children (list (make-child p 0 0 1 1 0 0))] 375 | [last (pict-last p)])) 376 | 377 | (define (set-pen #:color [color (make-color 0 0 0)] 378 | #:width [width 0] 379 | #:style [style 'solid] 380 | #:cap [cap 'round] 381 | #:join [join 'round] 382 | p) 383 | (dc/wrap p (λ (draw-p dc dx dy) 384 | (define old-pen (send dc get-pen)) 385 | (send dc set-pen (make-pen #:color color 386 | #:width width 387 | #:style style 388 | #:cap cap 389 | #:join join)) 390 | (draw-p dc dx dy) 391 | (send dc set-pen old-pen)))) 392 | 393 | (define (adjust-pen #:color [color #f] 394 | #:width [width #f] 395 | #:style [style #f] 396 | #:cap [cap #f] 397 | #:join [join #f] 398 | p) 399 | (define draw-p (make-pict-drawer p)) 400 | (struct-copy 401 | pict 402 | (dc (λ (dc dx dy) 403 | (define old-pen (send dc get-pen)) 404 | (send dc set-pen (make-pen #:color (or color (send old-pen get-color)) 405 | #:width (or width (send old-pen get-width)) 406 | #:style (or style (send old-pen get-style)) 407 | #:cap (or cap (send old-pen get-cap)) 408 | #:join (or join (send old-pen get-join)) 409 | #:stipple (send old-pen get-stipple))) 410 | (draw-p dc dx dy) 411 | (send dc set-pen old-pen)) 412 | (pict-width p) 413 | (pict-height p) 414 | (pict-ascent p) 415 | (pict-descent p)) 416 | [children (list (make-child p 0 0 1 1 0 0))] 417 | [last (pict-last p)])) 418 | 419 | ; Like cellophane from pict, but blends the entire pict as a single group. 420 | #;(define (cellophane p opacity) 421 | (dc/wrap p (λ (draw-p dc dx dy) 422 | (define old-alpha (send dc get-alpha)) 423 | (send dc set-alpha 1) 424 | (send dc push-group) 425 | (draw-p dc dx dy) 426 | (send dc set-alpha (* old-alpha opacity)) 427 | (send dc draw-group) 428 | (send dc set-alpha old-alpha)))) 429 | 430 | ; For debugging: add bounding box lines to the given pict. 431 | (define (metrics-frame p) 432 | (define metrics-line (hline (pict-width p) 0)) 433 | (define a (pict-ascent p)) 434 | (define b (- (pict-height p) (pict-descent p))) 435 | (define metrics (~> (rectangle (pict-width p) (pict-height p)) 436 | (pin-over 0 a (adjust-pen metrics-line #:color "red")) 437 | (pin-over 0 b (adjust-pen metrics-line #:color "blue" 438 | #:style (if (< (abs (- a b)) 0.0001) 439 | 'long-dash 440 | 'solid))) 441 | (set-pen))) 442 | (pin-over p 0 0 metrics)) 443 | 444 | (define (rsvg-isolate p) 445 | (define draw-p (make-pict-drawer p)) 446 | (dc (λ (dc x y) 447 | ; for reasons I cannot fathom, this prevents rsvg from screwing up the 448 | ; color of subsequent draw operations 449 | (define old-pen (send dc get-pen)) 450 | (send dc set-pen (make-pen #:style 'transparent)) 451 | (send dc draw-point -inf.0 -inf.0) 452 | (send dc set-pen old-pen) 453 | (draw-p dc x y)) 454 | (pict-width p) 455 | (pict-height p) 456 | (pict-ascent p) 457 | (pict-descent p))) 458 | 459 | ;; ----------------------------------------------------------------------------- 460 | ;; combiners 461 | 462 | (define (pin base-p arg1 arg2 sub-p #:hole [hole #(0 0)] #:order [order 'over]) 463 | (define-values [base-x base-y] 464 | (if (real? arg1) 465 | (values arg1 arg2) 466 | (arg2 base-p (find-child base-p arg1)))) 467 | 468 | (define-values [sub-x sub-y] 469 | (match hole 470 | [(vector (? real? sub-x) sub-y) 471 | (values sub-x sub-y)] 472 | [(vector path find) 473 | (find sub-p (find-child sub-p path))] 474 | [find 475 | (find sub-p sub-p)])) 476 | 477 | ((match order 478 | ['over pict:pin-over] 479 | ['under pict:pin-under]) 480 | base-p (- base-x sub-x) (- base-y sub-y) sub-p)) 481 | 482 | (define (pin-over base-p arg1 arg2 sub-p #:hole [hole #(0 0)]) 483 | (pin base-p arg1 arg2 sub-p #:hole hole #:order 'over)) 484 | (define (pin-under base-p arg1 arg2 sub-p #:hole [hole #(0 0)]) 485 | (pin base-p arg1 arg2 sub-p #:hole hole #:order 'under)) 486 | 487 | ; Combines picts by extending the last line, as determined by pict-last. 488 | (define (line-append p0 . ps) 489 | (foldl (λ (p2 p1) (line-append/2 p1 p2)) p0 ps)) 490 | (define (line-append/2 p1 p2) 491 | (define draw-p1 (make-pict-drawer p1)) 492 | (define draw-p2 (make-pict-drawer p2)) 493 | ; find the rightmost point on the baseline of (pict-last p1) 494 | (define-values [last-x last-y] (rbl-find p1 (or (pict-last p1) p1))) 495 | 496 | ; figure out where we’ll place p2 relative to p1, since we want to align the 497 | ; descent line of (pict-last p1) with the ascent line of p2 498 | (define p2-y-relative (- last-y (pict-ascent p2))) 499 | ; if p2-y is negative, that means p2’s ascent peeks out above the top of p1, 500 | ; so compute how far we need to offset p1/p2 relative to the top of the new pict 501 | (define p1-y (if (negative? p2-y-relative) (- p2-y-relative) 0)) 502 | (define p2-y (if (negative? p2-y-relative) 0 p2-y-relative)) 503 | 504 | ; the x coordinate is simpler, since we don’t have to deal with ascent/descent, 505 | ; but it’s possible (though unlikely) that last-x is negative, in which case we 506 | ; want to do a similar adjustment 507 | (define p1-x (if (negative? last-x) (- last-x) 0)) 508 | (define p2-x (if (negative? last-x) 0 last-x)) 509 | 510 | ; compute rightmost point and bottommost point in the new pict’s bounding box 511 | (define w (max (+ p1-x (pict-width p1)) 512 | (+ p2-x (pict-width p2)))) 513 | (define h (max (+ p1-y (pict-height p1)) 514 | (+ p2-y (pict-height p2)))) 515 | ; same for uppermost ascent line and lowermost descent line 516 | (define a (min (+ p1-y (pict-ascent p1)) 517 | (+ p2-y (pict-ascent p2)))) 518 | (define d (- h (max (+ p1-y (- (pict-height p1) (pict-descent p1))) 519 | (+ p2-y (- (pict-height p2) (pict-descent p2)))))) 520 | 521 | ; invent a new, totally unique pict to use as pict-last, in case (pict-last p2) 522 | ; already exists somewhere in the pict 523 | (define p2-last (or (ppath-last (pict-last p2)) p2)) 524 | (define-values [p2-last-x p2-last-y] (lt-find p2 (or (pict-last p2) p2))) 525 | (define last-p (blank (pict-width p2-last) 526 | (pict-height p2-last) 527 | (pict-ascent p2-last) 528 | (pict-descent p2-last))) 529 | 530 | ; compute child offsets, which are weird because pict uses an inverted 531 | ; coordinate system, so these are relative to the lowermost point 532 | (define p1-dy (- h (+ p1-y (pict-height p1)))) 533 | (define p2-dy (- h (+ p2-y (pict-height p2)))) 534 | (define p2-last-dy (- h (+ p2-y p2-last-y (pict-height p2-last)))) 535 | 536 | (~> (dc (λ (dc dx dy) 537 | (draw-p1 dc (+ dx p1-x) (+ dy p1-y)) 538 | (draw-p2 dc (+ dx p2-x) (+ dy p2-y))) 539 | w h a d) 540 | (struct-copy pict _ 541 | [children (list (make-child p1 p1-x p1-dy 1 1 0 0) 542 | (make-child p2 p2-x p2-dy 1 1 0 0) 543 | (make-child last-p 544 | (+ p2-x p2-last-x) 545 | p2-last-dy 546 | 1 1 0 0))] 547 | [last last-p]))) 548 | 549 | (struct spring (weight) #:transparent) 550 | (define (hflex width #:combine [combine hc-append] . elements) 551 | (define fixed-width (for/sum ([e (in-list elements)] #:unless (spring? e)) (pict-width e))) 552 | (define flexi-width (- width fixed-width)) 553 | (define total-weight (for/sum ([e (in-list elements)] #:when (spring? e)) (spring-weight e))) 554 | (define width-per-weight (/ flexi-width total-weight)) 555 | (apply combine (for/list ([element (in-list elements)]) 556 | (match element 557 | [(spring weight) (blank (* weight width-per-weight) 0)] 558 | [_ element])))) 559 | -------------------------------------------------------------------------------- /2023-06-delimited-continuations/lib/slideshow.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (except-in pict pin-over pin-under cellophane file-icon) 4 | racket/contract 5 | racket/match 6 | slideshow/base 7 | slideshow/code 8 | slideshow/text 9 | threading 10 | 11 | (prefix-in slideshow: slideshow/base) 12 | 13 | "pict.rkt" 14 | "util.rkt") 15 | 16 | (provide (contract-out [current-slide-margin (parameter/c real?)] 17 | [make-scaling-slide-assembler (->* [] [#:background-color pict-color/c 18 | #:annotate (-> pict? pict?)] 19 | (-> (or/c string? #f) 20 | exact-nonnegative-integer? 21 | pict? 22 | pict?))] 23 | 24 | [current-text-color (parameter/c (or/c pict-color/c #f))] 25 | [tt (-> string? pict?)] 26 | 27 | [para-spacing/c flat-contract?] 28 | [para-align/c flat-contract?] 29 | [current-para-spacing (parameter/c para-spacing/c)] 30 | [current-para-align (parameter/c para-align/c)] 31 | [current-para-fill? (parameter/c any/c)] 32 | [current-item-indent (parameter/c (or/c real? (-> real?)) real?)] 33 | [para (->* [] [#:width real? 34 | #:align para-align/c 35 | #:spacing para-spacing/c 36 | #:fill? any/c 37 | #:decode? any/c 38 | #:color (or/c pict-color/c #f)] 39 | #:rest (listof para-element/c) 40 | pict?)] 41 | [elem (->* [] [#:decode? any/c 42 | #:color (or/c pict-color/c #f)] 43 | #:rest (listof para-element/c) 44 | pict?)] 45 | [item (->* [] [#:width real? 46 | #:align para-align/c 47 | #:fill? any/c 48 | #:decode? any/c 49 | #:color (or/c pict-color/c #f)] 50 | #:rest (listof para-element/c) 51 | pict?)] 52 | [resolve-para-spacing (->* [] [para-spacing/c] real?)] 53 | [paras (->* [] [#:align para-align/c 54 | #:spacing para-spacing/c 55 | #:stage (or/c exact-integer? #f)] 56 | #:rest (listof pict?) 57 | pict?)])) 58 | 59 | ;; ----------------------------------------------------------------------------- 60 | ;; slide assembler 61 | 62 | (define current-slide-margin (make-parameter 20)) 63 | 64 | (define ((make-scaling-slide-assembler 65 | #:background-color [background-color "white"] 66 | #:annotate [annotate values]) 67 | title-str gap content) 68 | (define background 69 | (inset (filled-rectangle (+ client-w (* margin 2)) 70 | (+ client-h (* margin 2)) 71 | #:draw-border? #f 72 | #:color background-color) 73 | (- margin))) 74 | (define title (and title-str (~> ((current-titlet) title-str) 75 | (scale-to-fit client-w title-h)))) 76 | (define content-area 77 | (~> (if title 78 | (blank (pict-width background) 79 | (- (pict-height background) 80 | (pict-height title) 81 | gap)) 82 | (ghost background)) 83 | (inset (- (current-slide-margin))))) 84 | (define bounded-content (scale-to-fit content content-area #:mode 'inset)) 85 | (define title+content (if title (vc-append gap title bounded-content) bounded-content)) 86 | (cc-superimpose background 87 | (inset (annotate (blank (+ client-w (* margin 2)) 88 | (+ client-h (* margin 2)))) 89 | (- margin)) 90 | title+content)) 91 | 92 | ;; ----------------------------------------------------------------------------- 93 | ;; text and layout 94 | 95 | (define current-text-color (make-parameter #f)) 96 | 97 | (define (tt s) 98 | (with-font (current-code-font) 99 | (with-size ((get-current-code-font-size)) (t s)))) 100 | 101 | (define para-spacing/c (or/c real? (list/c 'lines real?))) 102 | (define para-align/c (or/c 'left 'center 'right)) 103 | (define para-element/c (flat-rec-contract elem/c 104 | (or/c string? pict? (listof elem/c)))) 105 | 106 | (define current-para-spacing (make-parameter '(lines 0.2))) 107 | (define current-para-align (make-parameter 'left)) 108 | (define current-para-fill? (make-parameter #t (λ (v) (and v #t)))) 109 | (define current-item-indent (make-lazy-parameter 0)) 110 | 111 | (define (para #:width [width (current-para-width)] 112 | #:align [align (current-para-align)] 113 | #:spacing [spacing (current-line-sep)] 114 | #:fill? [fill? (current-para-fill?)] 115 | #:decode? [decode? #t] 116 | #:color [color (current-text-color)] 117 | . elements) 118 | (parameterize ([current-line-sep (resolve-para-spacing spacing)]) 119 | (~> (apply slideshow:para #:width width #:align align #:fill? fill? #:decode? decode? elements) 120 | (maybe-colorize color)))) 121 | 122 | (define (elem #:decode? [decode? #t] 123 | #:color [color (current-text-color)] 124 | . elements) 125 | (apply para #:width +inf.0 #:fill? #f #:decode? decode? #:color color elements)) 126 | 127 | (define (item #:width [width (current-para-width)] 128 | #:align [align (current-para-align)] 129 | #:indent [indent (current-item-indent)] 130 | #:fill? [fill? (current-para-fill?)] 131 | #:decode? [decode? #t] 132 | #:color [color (current-text-color)] 133 | . elements) 134 | (define bullet (htl-append (blank indent 0) (elem "→") (blank (em 0.75) 0))) 135 | (htl-append bullet 136 | (apply para #:width (- width (pict-width bullet)) 137 | #:align align #:fill? fill? #:decode? decode? elements))) 138 | 139 | (define (resolve-para-spacing [spacing (current-para-spacing)]) 140 | (match spacing 141 | [(? real?) spacing] 142 | [(list 'lines n) (* (current-font-size) n)])) 143 | 144 | (define (paras #:align [align (current-para-align)] 145 | #:spacing [spacing (current-para-spacing)] 146 | #:stage [stage #f] 147 | . elements) 148 | (apply (match align 149 | ['left vl-append] 150 | ['center vc-append] 151 | ['right vr-append]) 152 | (resolve-para-spacing spacing) 153 | (for/list ([element (in-list elements)] 154 | [i (in-naturals)]) 155 | (pict-when (or (not stage) (< i stage)) element)))) 156 | -------------------------------------------------------------------------------- /2023-06-delimited-continuations/lib/unicode.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | racket/match) 5 | 6 | (provide (contract-out 7 | [char:minus char?] 8 | 9 | [math-char-style/c flat-contract?] 10 | [math-char (->* [char?] 11 | [#:bold? any/c 12 | #:italic? any/c 13 | #:style math-char-style/c] 14 | char?)] 15 | 16 | [superscript-char (-> char? char?)] 17 | [subscript-char (-> char? char?)] 18 | [integer->superscript-string (-> exact-integer? string?)] 19 | [integer->subscript-string (-> exact-integer? string?)])) 20 | 21 | ;; ----------------------------------------------------------------------------- 22 | 23 | (define char:minus #\u2212) 24 | 25 | (define (char+ c . ns) 26 | (integer->char (apply + (char->integer c) ns))) 27 | (define (char-diff c1 c2) 28 | (- (char->integer c1) (char->integer c2))) 29 | 30 | (define math-char-style/c 31 | (or/c 'serif 'sans-serif 'script 'fraktur 'monospace 'double-struck)) 32 | 33 | (define (math-char c 34 | #:bold? [bold? #f] 35 | #:italic? [italic? #f] 36 | #:style [style 'serif]) 37 | (define (bad-combo) 38 | (raise-arguments-error 'math-char "no character for style" 39 | "character" c 40 | "bold?" bold? 41 | "italic?" italic? 42 | "style" style)) 43 | 44 | (define (regular stride c) 45 | (match* {bold? italic?} 46 | [{#f #f} c] 47 | [{#t #f} (char+ c stride)] 48 | [{#f #t} (char+ c (* stride 2))] 49 | [{#t #t} (char+ c (* stride 3))])) 50 | 51 | (define (latin c c-offset) 52 | (match* {style bold? italic? c} 53 | [{'serif #f #t #\h} #\U210E] 54 | [{'serif _ _ _ } (regular 52 (char+ #\U1D3CC c-offset))] 55 | [{'sans-serif _ _ _ } (regular 52 (char+ #\U1D5A0 c-offset))] 56 | [{'script #f #f #\B} #\U212C] 57 | [{'script #f #f #\E} #\U2130] 58 | [{'script #f #f #\F} #\U2131] 59 | [{'script #f #f #\H} #\U210B] 60 | [{'script #f #f #\I} #\U2110] 61 | [{'script #f #f #\L} #\U2112] 62 | [{'script #f #f #\M} #\U2133] 63 | [{'script #f #f #\R} #\U211B] 64 | [{'script #f #f #\e} #\U212F] 65 | [{'script #f #f #\g} #\U210A] 66 | [{'script #f #f #\o} #\U2134] 67 | [{'script _ #f _ } (regular 52 (char+ #\U1D49C c-offset))] 68 | [{'fraktur #f #f #\C} #\U212D] 69 | [{'fraktur #f #f #\H} #\U210C] 70 | [{'fraktur #f #f #\I} #\U2111] 71 | [{'fraktur #f #f #\R} #\U211C] 72 | [{'fraktur #f #f #\Z} #\U2128] 73 | [{'fraktur _ #f _ } (regular 104 (char+ #\U1D504 c-offset))] 74 | [{'monospace #f #f _ } (char+ #\U1D670 c-offset)] 75 | [{'double-struck #f #f #\C} #\U2102] 76 | [{'double-struck #f #f #\H} #\U210D] 77 | [{'double-struck #f #f #\N} #\U2115] 78 | [{'double-struck #f #f #\P} #\U2119] 79 | [{'double-struck #f #f #\Q} #\U211A] 80 | [{'double-struck #f #f #\R} #\U211D] 81 | [{'double-struck #f #f #\Z} #\U2124] 82 | [{'double-struck #f #f _ } (char+ #\U1D538 c-offset)] 83 | [{_ _ _ _ } (bad-combo)])) 84 | 85 | (define (greek c-offset) 86 | (match* {style bold? italic?} 87 | [{'serif _ _ } (regular 58 (char+ #\U1D66E c-offset))] 88 | [{'sans-serif #t #f} (char+ #\U1D756 c-offset)] 89 | [{'sans-serif #t #t} (char+ #\U1D790 c-offset)] 90 | [{_ _ _ } (bad-combo)])) 91 | 92 | (define (digit c-offset) 93 | (match* {style bold? italic?} 94 | [{'serif #t #f} (char+ #\U1D7CE c-offset)] 95 | [{'sans-serif #f #f} (char+ #\U1D7E2 c-offset)] 96 | [{'sans-serif #t #f} (char+ #\U1D7EC c-offset)] 97 | [{'monospace #f #f} (char+ #\U1D7F6 c-offset)] 98 | [{'double-struck #f #f} (char+ #\U1D7D8 c-offset)] 99 | [{_ _ _ } (bad-combo)])) 100 | 101 | (cond 102 | [(and (not bold?) (not italic?) (eq? style 'serif)) c] 103 | [(char<=? #\A c #\Z) (latin c (char-diff c #\A))] 104 | [(char<=? #\a c #\z) (latin c (+ (char-diff c #\a) 26))] 105 | [(or (char<=? #\U391 c #\U3A1) 106 | (char<=? #\Σ c #\Ω) 107 | (char<=? #\α c #\ω)) 108 | (greek (char-diff c #\U391))] 109 | [(char=? c #\Θ) (greek 11)] 110 | [(char=? c #\∇) (greek 19)] 111 | [(char=? c #\U2202) (greek 39)] 112 | [(char=? c #\U03F5) (greek 40)] 113 | [(char=? c #\U03D1) (greek 41)] 114 | [(char=? c #\U03F0) (greek 42)] 115 | [(char=? c #\U03D5) (greek 43)] 116 | [(char=? c #\U03F1) (greek 44)] 117 | [(char=? c #\U03D6) (greek 45)] 118 | [(char<=? #\0 c #\9) (digit (char-diff c #\0))] 119 | [else (bad-combo)])) 120 | 121 | (define (superscript-char c) 122 | (match c 123 | [#\1 #\u00B9] 124 | [#\2 #\u00B2] 125 | [#\3 #\u00B3] 126 | [#\+ #\u207A] 127 | [(== char:minus) #\u207B] 128 | [#\= #\u207C] 129 | [#\( #\u207D] 130 | [#\) #\u207E] 131 | [#\n #\u207F] 132 | [_ 133 | (if (char<=? #\0 c #\9) 134 | (char+ #\u2070 (char-diff c #\0)) 135 | (raise-arguments-error 'superscript-char "no superscript variant for character" 136 | "character" c))])) 137 | 138 | (define (subscript-char c) 139 | (cond 140 | [(char<=? #\0 c #\9) 141 | (char+ #\u2080 (char-diff c #\0))] 142 | [else 143 | (match c 144 | [#\+ #\u208A] 145 | [(== char:minus) #\u208B] 146 | [#\= #\u208C] 147 | [#\( #\u208D] 148 | [#\) #\u208E] 149 | [#\a #\u2090] 150 | [#\e #\u2091] 151 | [#\o #\u2092] 152 | [#\x #\u2093] 153 | [#\ə #\u2094] 154 | [#\h #\u2095] 155 | [#\k #\u2096] 156 | [#\l #\u2097] 157 | [#\m #\u2098] 158 | [#\n #\u2099] 159 | [#\p #\u209A] 160 | [#\s #\u209B] 161 | [#\t #\u209C] 162 | [_ 163 | (raise-arguments-error 'subscript-char "no subscript variant for character" 164 | "character" c)])])) 165 | 166 | (define (integer->script-string n convert-char) 167 | (define num-str (number->string n)) 168 | (define len (string-length num-str)) 169 | (define str (if (immutable? num-str) (make-string len) num-str)) 170 | (for ([i (in-range len)]) 171 | (define c (string-ref num-str i)) 172 | (string-set! str i (convert-char (if (char=? c #\-) char:minus c)))) 173 | str) 174 | 175 | (define (integer->superscript-string n) 176 | (integer->script-string n superscript-char)) 177 | 178 | (define (integer->subscript-string n) 179 | (integer->script-string n subscript-char)) 180 | -------------------------------------------------------------------------------- /2023-06-delimited-continuations/lib/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | racket/function 5 | racket/math 6 | syntax/parse/define 7 | threading) 8 | 9 | (provide when~> unless~> 10 | (contract-out [make-lazy-parameter (-> any/c parameter?)] 11 | [lazy-parameter/c (->* [contract?] [contract?] contract?)] 12 | [turns (-> real? real?)])) 13 | 14 | (define (make-lazy-parameter val) 15 | (make-derived-parameter (make-parameter val) 16 | identity 17 | (λ (v) (if (procedure? v) (v) v)))) 18 | 19 | (define (lazy-parameter/c in-ctc [out-ctc in-ctc]) 20 | (parameter/c (or/c in-ctc (-> in-ctc)) out-ctc)) 21 | 22 | (define-simple-macro (when~> e:expr c:expr s:expr ...) 23 | (let ([v e]) (if c (~> v s ...) v))) 24 | (define-simple-macro (unless~> e:expr c:expr s:expr ...) 25 | (let ([v e]) (if c v (~> v s ...)))) 26 | 27 | (define (turns n) (* 2 pi n)) 28 | -------------------------------------------------------------------------------- /2023-06-delimited-continuations/slides-uncondensed.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2023-06-delimited-continuations/slides-uncondensed.pdf -------------------------------------------------------------------------------- /2023-06-delimited-continuations/slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/2023-06-delimited-continuations/slides.pdf -------------------------------------------------------------------------------- /hasura/2019-12-schema-cache-refactor/assets/incremental-pr-build.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/hasura/2019-12-schema-cache-refactor/assets/incremental-pr-build.png -------------------------------------------------------------------------------- /hasura/2019-12-schema-cache-refactor/assets/incremental-pr.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/hasura/2019-12-schema-cache-refactor/assets/incremental-pr.png -------------------------------------------------------------------------------- /hasura/2019-12-schema-cache-refactor/assets/timed.1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/hasura/2019-12-schema-cache-refactor/assets/timed.1.png -------------------------------------------------------------------------------- /hasura/2019-12-schema-cache-refactor/assets/timed.2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/hasura/2019-12-schema-cache-refactor/assets/timed.2.png -------------------------------------------------------------------------------- /hasura/2020-01-arrows/arrows.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/hasura/2020-01-arrows/arrows.pdf -------------------------------------------------------------------------------- /hasura/2020-01-arrows/assets/proposal-pr.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/hasura/2020-01-arrows/assets/proposal-pr.png -------------------------------------------------------------------------------- /hasura/2020-01-arrows/assets/typechecking-rules.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/talks/99cc29912d1427509b33d4a82e3689bc9c572436/hasura/2020-01-arrows/assets/typechecking-rules.png -------------------------------------------------------------------------------- /hasura/lib/1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/class 4 | racket/contract 5 | racket/function 6 | racket/list 7 | racket/match 8 | racket/runtime-path 9 | threading 10 | 11 | racket/draw 12 | (rename-in pict [colorize pict:colorize]) 13 | pict/conditional 14 | pict/convert 15 | ppict/align 16 | 17 | (rename-in slideshow/base [current-font-size current-text-size] [slide slideshow:slide]) 18 | slideshow/code) 19 | 20 | (provide (all-from-out racket/class racket/contract racket/function racket/list racket/match threading 21 | racket/draw pict pict/conditional ppict/align 22 | slideshow/base slideshow/code) 23 | make-lazy-parameter 24 | align->superimpose 25 | pict-when 26 | pict-unless 27 | 28 | (contract-out 29 | [color (-> color? (or/c #f string? (is-a?/c color%)))] 30 | [colorize (-> pict-convertible? color? pict?)] 31 | 32 | [current-text-color (parameter/c color?)] 33 | [current-title-text-color (parameter/c color?)] 34 | [t (->* [] [#:align halign/c] #:rest (listof (or/c string? pict?)) pict?)] 35 | [tt (-> string? pict?)] 36 | [itt (-> string? pict?)] 37 | [btt (-> string? pict?)])) 38 | 39 | ;; --------------------------------------------------------------------------------------------------- 40 | ;; miscellaneous helpers 41 | 42 | (define (make-lazy-parameter val) 43 | (make-derived-parameter (make-parameter val) 44 | identity 45 | (λ (v) (if (procedure? v) (v) v)))) 46 | 47 | (define keyword-apply/defaults 48 | (make-keyword-procedure 49 | (λ (def-kws def-kw-args proc given-kws given-kw-args pos-args) 50 | (define kws+args (for/fold ([kws+args (map cons given-kws given-kw-args)] 51 | #:result (sort kws+args keywordsuperimpose align) 63 | (case align 64 | [(lt) lt-superimpose] 65 | [(ct) ct-superimpose] 66 | [(rt) rt-superimpose] 67 | [(lc) lc-superimpose] 68 | [(cc) cc-superimpose] 69 | [(rc) rc-superimpose] 70 | [(lb) lb-superimpose] 71 | [(cb) cb-superimpose] 72 | [(rb) rb-superimpose])) 73 | 74 | ;; --------------------------------------------------------------------------------------------------- 75 | ;; staging 76 | 77 | (define (pict-when test then) 78 | (pict-if test then (blank))) 79 | (define (pict-unless test then) 80 | (pict-if test (blank) then)) 81 | 82 | ;; --------------------------------------------------------------------------------------------------- 83 | ;; colors 84 | 85 | (define color? 86 | (flat-named-contract 87 | 'color? 88 | (or/c #f string? (is-a? color%) (integer-in 0 #xFFFFFF)))) 89 | 90 | (define (color v) 91 | (match v 92 | [(or #f (? string?)) v] 93 | [(? exact-integer?) (make-color (bitwise-bit-field v 16 24) 94 | (bitwise-bit-field v 8 16) 95 | (bitwise-bit-field v 0 8))])) 96 | 97 | (define (colorize p c) (if color (pict:colorize p (color c)) p)) 98 | 99 | ;; --------------------------------------------------------------------------------------------------- 100 | ;; text 101 | 102 | (define current-text-color (make-parameter #f)) 103 | (define current-title-text-color (make-lazy-parameter current-text-color)) 104 | 105 | (define (t #:align [align 'l] . args) 106 | (~>> (for/fold ([lines '()] [line '()] #:result (reverse (cons (reverse line) lines))) 107 | ([arg (in-list args)]) 108 | (match arg 109 | ["\n" (values (cons (reverse line) lines) '())] 110 | [(? string?) (values lines (~> (text arg (current-main-font) (current-text-size)) 111 | (colorize (current-text-color)) 112 | (cons line)))] 113 | [_ (values lines (cons arg line))])) 114 | (map (λ~>> (apply hbl-append))) 115 | (apply (halign->vcompose align)))) 116 | 117 | (define (tt s) (text s (current-code-font) (current-text-size))) 118 | (define (itt s) (text s (cons 'italic (current-code-font)) (current-text-size))) 119 | (define (btt s) (text s (cons 'bold (current-code-font)) (current-text-size))) 120 | -------------------------------------------------------------------------------- /hasura/lib/assets/hasura_icon_black.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 8 | 9 | 10 | 11 | 12 | 17 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /hasura/lib/assets/postgres_logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | --------------------------------------------------------------------------------