├── LICENSE ├── README.md ├── diagrama-doc ├── diagrama │ ├── info.rkt │ └── scribblings │ │ ├── base.rkt │ │ ├── diagrama.scrbl │ │ └── reference.scrbl └── info.rkt ├── diagrama-lib ├── diagrama │ ├── circuit.rkt │ ├── main.rkt │ └── private │ │ └── shared.rkt └── info.rkt └── diagrama └── info.rkt /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | Copyright © 2019 Spencer Florence 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 5 | 6 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 7 | 8 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 9 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A diagram drawing library for Racket 2 | -------------------------------------------------------------------------------- /diagrama-doc/diagrama/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define scribblings '(("scribblings/diagrama.scrbl" ()))) 4 | -------------------------------------------------------------------------------- /diagrama-doc/diagrama/scribblings/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | scribble/examples 4 | (for-label racket pict pict/convert diagrama diagrama/circuit racket/draw)) 5 | 6 | (provide 7 | diag 8 | (all-from-out scribble/examples) 9 | (for-label 10 | (all-from-out racket pict pict/convert diagrama diagrama/circuit racket/draw))) 11 | 12 | (define diag 13 | (make-base-eval 14 | #:lang 'racket 15 | '(require diagrama diagrama/circuit pict racket/draw))) -------------------------------------------------------------------------------- /diagrama-doc/diagrama/scribblings/diagrama.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @;@(require "base.rkt") 3 | @title{Diagrama: A diagram drawing library} 4 | 5 | @author[(author+email "Spencer Florence" "spencer@florence.io")] 6 | 7 | @declare-exporting[diagrama] 8 | 9 | Digrama is a library for drawing diagrams on top of @racketmodname[pict]. 10 | 11 | @include-section["reference.scrbl"] -------------------------------------------------------------------------------- /diagrama-doc/diagrama/scribblings/reference.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @title{Diagrama API Reference} 3 | @(require "base.rkt") 4 | @defmodule[diagrama #:use-sources (diagrama)] 5 | 6 | @bold{Warning:} The API presented here is unstable, and may change without warning. 7 | 8 | @defproc[(diagram? [it any/c]) 9 | boolean?]{ 10 | 11 | Is @racket[it] a Diagram. Diagrams are computations that 12 | draw, well, diagrams. Diagrams have a state which consists 13 | of a current drawing location, a notion of units, a 14 | line-width, and line-color. 15 | 16 | Diagrams are @racket[pict-convertible?]. When diagrams are 17 | drawn the whole image is shifted such that the minimum x and 18 | y coordinate are shifted to the origin. When diagrams are 19 | converted to @racket[pict?]s the starting coordinates are 20 | always (@racket[0],@racket[0]). 21 | 22 | } 23 | 24 | @section{Basic diagram constructors} 25 | 26 | @defthing[nothing diagram?]{ 27 | An empty diagram. 28 | } 29 | 30 | @defproc[(img [p pict-convertible?] 31 | [align (or/c 'lt 'ct 'rt 'lc 'cc 'rc 'lb 'cb 'rb) 'cc]) 32 | diagram?]{ 33 | 34 | Convert this @racket[p] into a diagram which just draws @racket[p]. 35 | The part of @racket[p] designated by @racket[align] controls 36 | which part of @racket[p] is placed at the current location. For 37 | example @racket['cc] centers it. 38 | 39 | } 40 | 41 | @defproc[(path [path (is-a?/c dc-path%)] 42 | [fill-style (or/c 'odd-even 'winding) 'odd-even]) 43 | diagram?]{ 44 | 45 | Draw the given path. The path is interpreted in terms 46 | of the current location and units, and the current location 47 | after drawing the path is the location of the last 48 | point in the paths. The path is not mutated. 49 | 50 | The @racket[fill-style] is the same as the same argument 51 | from @method[dc<%> draw-path]. 52 | 53 | @examples[#:eval diag 54 | (define unit-line-right 55 | (let () 56 | (define p (new dc-path%)) 57 | (send p move-to 0 0) 58 | (send p line-to 1 0) 59 | (path p))) 60 | unit-line-right 61 | (after (move-to 3 0) unit-line-right) 62 | (after (units 36) (move-to 3 0) unit-line-right) 63 | (after (units 36) (move-to 3 0) (color "red") unit-line-right)] 64 | 65 | } 66 | 67 | @defproc[(line-to [x real?] [y real?] [#:h-first h-fit any/c #t]) 68 | diagram?]{ 69 | 70 | Creates a diagram which draws a line from the current 71 | location to (@racket[x],@racket[y]). The line moves only 72 | horizontally and vertically. If @racket[h-first] is 73 | not @racket[#f] it moves horizontally then vertically, otherwise 74 | it does the reverse. 75 | 76 | 77 | @examples[#:eval diag 78 | (line-to 3 2)] 79 | 80 | } 81 | @deftogether[(@defproc[(line-left [d real?]) diagram?] 82 | @defproc[(line-right [d real?]) diagram?] 83 | @defproc[(line-up [d real?]) diagram?] 84 | @defproc[(line-down [d real?]) diagram?])]{ 85 | Create a diagram which draws a line from the current location 86 | @racket[d] away in the given direction. 87 | @examples[#:eval diag 88 | (line-right 5) 89 | (line-up 5)] 90 | } 91 | 92 | @defproc[(move-to [x real?] [y real?]) diagram?]{ 93 | 94 | Makes an empty diagram which moves the current drawing 95 | location to (@racket[x],@racket[y]), with 96 | (@racket[0],@racket[0]) being in the upper left. 97 | 98 | @examples[#:eval diag 99 | (after 100 | (move-to 3 3) 101 | (line-right 5))] 102 | 103 | } 104 | 105 | @deftogether[(@defproc[(move-left [d real?]) diagram?] 106 | @defproc[(move-right [d real?]) diagram?] 107 | @defproc[(move-up [d real?]) diagram?] 108 | @defproc[(move-down [d real?]) diagram?])]{ 109 | Makes an empty diagram which moves the current location 110 | by @racket[d] in the corresponding direction. 111 | } 112 | 113 | 114 | 115 | @defproc[(tag-location [name any/c] 116 | [x real? #f] 117 | [y real? #f]) 118 | diagram?]{ 119 | Make an empty diagram that names ta location @racket[name]. 120 | If @racket[x] and @racket[y] given that location is 121 | named, otherwise the current location is names. 122 | This will overwrite any existing locations which have a name @racket[equal?] 123 | to @racket[name]. 124 | 125 | } 126 | 127 | @defproc[(move-to-tag [name any/c]) diagram?]{ 128 | 129 | Move to the location with the given @racket[name]. Errors 130 | if no location has that @racket[name]. 131 | 132 | } 133 | 134 | @defproc[(line-to-tag [name any/c] [#:h-first h-fit any/c #t]) 135 | diagram?]{ 136 | 137 | Draw a line from the current location to the location with 138 | the given @racket[name]. Errors if no location has that 139 | @racket[name]. The line is drawn like @racket[line-to]. 140 | 141 | @examples[#:eval diag 142 | (after 143 | (tag-location 'here 3 3) 144 | (move-to 0 0) 145 | (line-to-tag 'here))] 146 | } 147 | 148 | @defproc[(line-between [start any/c] [end any/c] [#:h-first h-fit any/c #t]) diagram]{ 149 | 150 | Draw a line between the two named coordinates. See also 151 | @racket[line-to-tag] and @racket[line-to]. 152 | 153 | @examples[#:eval diag 154 | (after 155 | (tag-location 'here 1 2) 156 | (tag-location 'there 4 0) 157 | (line-between 'here 'there))] 158 | 159 | } 160 | 161 | @defproc[(units [u positive?]) diagram?]{ 162 | 163 | Create an empty diagram that changes the current 164 | size of the coordinate system to @racket[u]. The default 165 | is @racket[12]. 166 | 167 | @examples[#:eval diag 168 | (define l (line-right 1)) 169 | l 170 | (after (units 36) l)] 171 | 172 | } 173 | 174 | @defproc[(color [c (or/c string? (is-a?/c color%))]) diagram?]{ 175 | 176 | Create an empty diagram that changes 177 | the current line color. 178 | 179 | @examples[#:eval diag 180 | (after (units 36) (color "red") 181 | (line-right 2))] 182 | 183 | } 184 | 185 | @defproc[(line-width [l (real-in 0 255)]) diagram?]{ 186 | 187 | Create an empty diagram that changes 188 | the current line width. 189 | 190 | } 191 | 192 | @defproc[(label [t string?] [dir (or/c 'up 'down 'left 'right)]) 193 | diagram?]{ 194 | 195 | Add text to the diagram one unit in the given direction. 196 | 197 | @examples[#:eval diag 198 | (after 199 | (units 24) 200 | (save (label "Line" 'right)) 201 | (line-up 1) 202 | (line-down 2))] 203 | 204 | } 205 | 206 | @defthing[unit-grid diagram?]{ 207 | 208 | Draws a grid over the current diagram with length/width of each 209 | cell of unit length. 210 | 211 | @examples[#:eval diag 212 | (define l (line-right 3)) 213 | l 214 | (after l unit-grid) 215 | (after l (units 24) unit-grid) 216 | (after (units 24) l unit-grid) 217 | (after 218 | (save l) 219 | (move-down 1) (save l) 220 | (move-down 1) (save l) 221 | unit-grid)] 222 | 223 | } 224 | 225 | @section{Diagram composition} 226 | 227 | @defproc[(after [d diagram?] ...) diagram?]{ 228 | 229 | Draw all of the @racket[d]s one after another. 230 | 231 | @examples[#:eval diag 232 | (after 233 | (line-up 3) 234 | (line-right 3) 235 | (line-down 3) 236 | (line-left 3))] 237 | } 238 | 239 | @defproc[(before [d1 diagram?] [d diagram?] ...) diagram?]{ 240 | 241 | Draw all of the @racket[d]s one after another, then 242 | draw @racket[d1] at with initial state of the diagram. 243 | 244 | @examples[#:eval diag 245 | (after (img (disk 36 #:color "white")) 246 | (line-right 3)) 247 | (before (img (disk 36 #:color "white")) 248 | (line-right 3))] 249 | 250 | } 251 | 252 | @defproc[(save [d diagram?] ...) diagram?]{ 253 | Draw all of @racket[d] one after another, 254 | then resort the current units and location 255 | to what they were at the start of the @racket[save]. 256 | } 257 | 258 | @defproc[(save/bounds [d diagram?] ...) diagram?]{ 259 | 260 | Like @racket[save] except the bounds of the diagram are are 261 | restored after the @racket[d]s are draw. This allows for 262 | drawing outside of the bounds of the resulting @racket[pict?]. 263 | 264 | } 265 | 266 | @defproc[(split [d1 diagram?] [d2 diagram]) 267 | diagram?]{ 268 | Draw @racket[d1] and @racket[d2] with the current 269 | state, and place a black dot at the current location. The 270 | resulting state is the state from @racket[d2]. 271 | 272 | @examples[#:eval diag 273 | (after 274 | (line-right 3) 275 | (split 276 | (after (line-up 3) (line-right 3)) 277 | (after (line-down 3) (line-right 3))) 278 | (line-down 3))] 279 | } 280 | 281 | @defproc[(*> [d1 diagram?] [d diagram?] ...) diagram?]{ 282 | 283 | Draw all of the diagrams in order, with each being drawn 284 | with the initial state. The resulting state is that of the 285 | last diagram. 286 | 287 | @examples[#:eval diag 288 | (after 289 | (units 36) 290 | (*> (line-up 1) 291 | (line-down 1) 292 | (line-left 1) 293 | (line-right 1)) 294 | (line-down 1))] 295 | 296 | } 297 | 298 | @defproc[(<* [d1 diagram?] [d diagram?] ...) diagram?]{ 299 | 300 | Draw all of the diagrams in order, with each being drawn 301 | with the initial state. The resulting state is that of the 302 | first diagram. 303 | 304 | @examples[#:eval diag 305 | (after 306 | (units 36) 307 | (<* (line-up 1) 308 | (line-down 1) 309 | (line-left 1) 310 | (line-right 1)) 311 | (line-right 1))] 312 | 313 | } 314 | 315 | @defproc[(start-at [#:ud ud (or/c 'up 'down)] 316 | [#:lr lr (or/c 'left 'right)] 317 | [d diagram?] ...) 318 | diagram]{ 319 | 320 | Draw the diagrams in order, with each starting at the 321 | location on the corner of the previous specified by 322 | @racket[ud] and @racket[lr]. The first diagram 323 | is drawn at the current location. 324 | 325 | } 326 | 327 | @deftogether[(@defform[(for/after (for-clauses ...) body-or-break ... body)] 328 | @defform[(for*/after (for-clauses ...) body-or-break ... body)] 329 | @defform[(for/*> (for-clauses ...) body-or-break ... body)] 330 | @defform[(for*/*> (for-clauses ...) body-or-break ... body)] 331 | @defform[(for/<* (for-clauses ...) body-or-break ... body)] 332 | @defform[(for*/<* (for-clauses ...) body-or-break ... body)])]{ 333 | 334 | Your friendly neighborhood @racket[for] forms, for building 335 | diagrams using @racket[after], @racket[*>], and @racket[<*]. 336 | 337 | } 338 | 339 | 340 | @section{Reflecting on the drawing state} 341 | 342 | There are several ways to directly inspect the current 343 | drawing state. These are all fairly low level operations 344 | that are most likely useful for making new combinators, or when 345 | making @racket[pict?]'s that scale to the current unit size (for 346 | example @racket[unit-grid] and @racket[start-at] are defined 347 | with these). 348 | 349 | @defproc[(with-loc 350 | [builder (-> real? real? diagram?)]) 351 | diagram?]{ 352 | Build a diagram using the current (x,y) location. 353 | } 354 | 355 | @defproc[(with-bounds 356 | [builder (-> real? real? real? real? diagram?)]) 357 | diagram?]{ 358 | Build a diagram given the current bounding box. See @racket[with-state] 359 | for the order of arguments to @racket[builder]. 360 | } 361 | 362 | @defproc[(with-color 363 | [builder (-> (or/c string? (is-a?/c color%)) diagram?)]) 364 | diagram?]{ 365 | 366 | Build a diagram using the current color. 367 | 368 | } 369 | 370 | @defproc[(with-line-width 371 | [builder (-> (real-in 0 255) diagram?)]) 372 | diagram?]{ 373 | 374 | Build a diagram using the current line width. 375 | 376 | } 377 | 378 | @defproc[(with-unit 379 | [builder (-> real? diagram?)]) 380 | diagram?]{ 381 | 382 | Build a diagram given the current units. 383 | 384 | @examples[#:eval diag 385 | (define unit-circle 386 | (with-unit (compose img circle))) 387 | unit-circle 388 | (after (units 24) unit-circle) 389 | (scale 390 | (after 391 | (units 24) 392 | (for*/fold ([p nothing]) 393 | ([x (in-range 3)] 394 | [y (in-range 3)]) 395 | (after p 396 | (move-to x y) 397 | unit-circle)) 398 | unit-grid) 399 | 2)] 400 | 401 | 402 | } 403 | 404 | @defproc[(with-location-of [tag any/c] 405 | [builder (-> real? real? diagram?)]) 406 | diagram?]{ 407 | 408 | Build a diagram using the the given named location. 409 | 410 | } 411 | 412 | @section{Circuit Helpers} 413 | 414 | @defmodule[diagrama/circuit #:use-sources (diagrama/circuit)] 415 | 416 | @racketmodname[diagrama/circuit] has helpers for drawing 417 | circuit diagrams. Note that it is easy to accidentally draw 418 | lines on top of gates: @racket[before] is designed to help 419 | with this. 420 | 421 | @deftogether[(@defproc[(or-gate 422 | [#:in1 n1 any/c #f] 423 | [#:in2 n2 any/c #f] 424 | [#:in3 n3 any/c #f] 425 | [#:out out any/c #f] 426 | [#:tag-in1 tag1 any/c #f] 427 | [#:tag-in2 tag2 any/c #f] 428 | [#:tag-in3 tag3 any/c #f] 429 | [#:tag-out tag4 any/c #f]) 430 | diagram?] 431 | @defproc[(and-gate 432 | [#:in1 n1 any/c #f] 433 | [#:in2 n2 any/c #f] 434 | [#:in3 n3 any/c #f] 435 | [#:out out any/c #f] 436 | [#:tag-in1 tag1 any/c #f] 437 | [#:tag-in2 tag2 any/c #f] 438 | [#:tag-in3 tag3 any/c #f] 439 | [#:tag-out tag4 any/c #f]) 440 | diagram?] 441 | @defproc[(buffer 442 | [#:in2 n2 any/c #f] 443 | [#:out out any/c #f] 444 | [#:tag-in2 tag2 any/c #f] 445 | [#:tag-out tag4 any/c #f]) 446 | diagram?] 447 | @defproc[(register 448 | [#:in2 n2 any/c #f] 449 | [#:out out any/c #f] 450 | [#:tag-in2 tag2 any/c #f] 451 | [#:tag-out tag4 any/c #f]) 452 | diagram?])]{ 453 | 454 | Make a diagram that draws the given gate, each gate facing 455 | to the right. @racket[or-gate] and @racket[and-gate] are 456 | three units square, and designed to take in up to three 457 | input wires. @racket[buffer] and @racket[register] are 458 | roughly the same size, but are designed to take only one 459 | input. If @racket[n1], @racket[n2], or @racket[n3] are not 460 | @racket[#f], then the upper, middle, or lower input 461 | (respectively) are negated. @racket[out] does the same for 462 | the output. If @racket[tag1], @racket[tag2] or @racket[tag3] 463 | a wire is drawn for those inputs, and its endpoint is named 464 | by the given tag. @racket[tag4] does the same for the 465 | output. 466 | 467 | The drawn gate is centered at the current location. 468 | 469 | @examples[#:eval diag 470 | (define layer-1-x 6) 471 | (define layer-2-x 3) 472 | 473 | (define input-1 (tag-location 'input-1 0 0)) 474 | (define input-2 (tag-location 'input-2 0 2)) 475 | (define top-gate 476 | (after 477 | (move-down 1) (move-right layer-1-x) 478 | (and-gate #:out #t 479 | #:tag-out 'and-out 480 | #:tag-in1 'and-A 481 | #:tag-in3 'and-B))) 482 | (define lower-gate 483 | (after 484 | (move-down 5) (move-right layer-1-x) 485 | (or-gate #:tag-out 'or-out 486 | #:tag-in1 'or-A 487 | #:tag-in3 'or-B))) 488 | (define last-gate 489 | (after 490 | (move-down 1) (move-right layer-2-x) 491 | (and-gate #:tag-in1 'and-in 492 | #:tag-in3 'or-in 493 | #:tag-out 'result))) 494 | (define (connect-input input g1 g2 split-point) 495 | (after 496 | (move-to-tag input) 497 | (line-right split-point) 498 | (split 499 | (line-to-tag g1) 500 | (line-to-tag g2 #:h-first #f)))) 501 | (define xor 502 | (after 503 | input-1 input-2 504 | (move-to-tag 'input-1) 505 | (save top-gate) (save lower-gate) 506 | (move-to-tag 'and-out) last-gate 507 | (connect-input 'input-1 'and-A 'or-A 3) 508 | (connect-input 'input-2 'and-B 'or-B 2) 509 | (line-between 'and-out 'and-in) 510 | (line-between 'or-out 'or-in) 511 | (move-to-tag 'result) 512 | (line-right 1))) 513 | (scale xor 2) 514 | (scale (after xor unit-grid) 2)] 515 | 516 | } 517 | 518 | -------------------------------------------------------------------------------- /diagrama-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '(("base" #:version "7.4"))) 6 | 7 | (define build-deps '("diagrama-lib" 8 | "pict-lib" 9 | "draw-doc" 10 | "draw-lib" 11 | "pict-doc" 12 | "racket-doc" 13 | "scribble-lib")) 14 | 15 | (define pkg-desc "Documentation part of `diagrama`") 16 | 17 | (define version "0.1") 18 | -------------------------------------------------------------------------------- /diagrama-lib/diagrama/circuit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract) 3 | (provide 4 | (contract-out 5 | [or-gate 6 | (->* () 7 | (#:line-length (>=/c 0) 8 | #:in1 any/c 9 | #:in2 any/c 10 | #:in3 any/c 11 | #:out any/c 12 | #:tag-in1 any/c 13 | #:tag-in2 any/c 14 | #:tag-in3 any/c 15 | #:tag-out any/c) 16 | diagram?)] 17 | [and-gate 18 | (->* () 19 | (#:line-length (>=/c 0) 20 | #:in1 any/c 21 | #:in2 any/c 22 | #:in3 any/c 23 | #:out any/c 24 | #:tag-in1 any/c 25 | #:tag-in2 any/c 26 | #:tag-in3 any/c 27 | #:tag-out any/c) 28 | diagram?)] 29 | [buffer (->* () 30 | (#:line-length (>=/c 0)#:in2 any/c 31 | #:out any/c 32 | #:tag-in2 any/c 33 | #:tag-out any/c) 34 | diagram?)] 35 | [register 36 | (->* () 37 | (#:line-length (>=/c 0) 38 | #:in2 any/c 39 | #:out any/c 40 | #:tag-in2 any/c 41 | #:tag-out any/c) 42 | diagram?)])) 43 | (require "main.rkt" 44 | racket/draw 45 | racket/class 46 | racket/match 47 | racket/string 48 | racket/list 49 | pict) 50 | 51 | (define (gate-size s) 52 | (* s 3)) 53 | 54 | (define (interpret-path-commands commands) 55 | (define p (new dc-path%)) 56 | (interpret-path-commands! p commands) 57 | p) 58 | (define (interpret-path-commands! p commands) 59 | (match commands 60 | [(list) (void)] 61 | [(cons a b) 62 | (interpret-single-path-command! p a) 63 | (interpret-path-commands! p b)])) 64 | 65 | (define (interpret-single-path-command! p a) 66 | (match a 67 | [`(M (,x ,y)) 68 | (send p move-to x y)] 69 | [`(C (,x1 ,y1) (,x2 ,y2) (,x3 ,y3)) 70 | (send p curve-to x1 y1 x2 y2 x3 y3)] 71 | [`(L (,x ,y)) 72 | (send p line-to x y)] 73 | [`(z) (send p close)])) 74 | 75 | 76 | (define (parse-path-commands s) 77 | (map parse-single-path-command 78 | (map string-trim 79 | (regexp-match* #rx"[MmLlHhVvQqTtAaZzCcSs][^MmLlHhVvQqTtAaZzCcSs]*" s)))) 80 | 81 | (define (parse-single-path-command s) 82 | (define (valueize x) 83 | (read (open-input-string x))) 84 | (define bits (string-split s)) 85 | (cons (valueize (first bits)) 86 | (map (lambda (x) (map valueize (string-split x ","))) 87 | (rest bits)))) 88 | 89 | 90 | (define (make-gate-pict-maker p* 91 | nn1 nn2 nn3 92 | #:fill? [fill? #f] 93 | #:override-path-width [ow #f] 94 | #:override-path-height [oh #f] 95 | #:override-path-left [ol #f] 96 | #:override-path-top [ot #f]) 97 | (lambda (n1 n2 n3 n4) 98 | (define p (new dc-path%)) 99 | (send p append p*) 100 | (define-values (l t w h) 101 | (send p get-bounding-box)) 102 | (send p transform 103 | (vector 1 0 0 1 (- (or ol l)) (- (or ot t)))) 104 | (send p transform 105 | (vector (* (/ 1 (or ow w)) (gate-size 1)) 0 106 | 0 (* (/ 1 (or oh h)) (gate-size 1)) 107 | (- (gate-size .5)) (- (gate-size .5)))) 108 | (after 109 | (if fill? 110 | (with-unit 111 | (lambda (u) 112 | (img (filled-rectangle 113 | (* u (gate-size 1)) (* u (gate-size 1)) 114 | #:draw-border? #f 115 | #:color "white")))) 116 | nothing) 117 | (save (path p)) 118 | (save (if n1 (path (not-at nn1 1/6)) nothing)) 119 | (save (if n2 (path (not-at nn2 0.5)) nothing)) 120 | (save (if n3 (path (not-at nn3 5/6)) nothing)) 121 | (save (if n4 (path (not-at 1 .5)) nothing))))) 122 | 123 | (define (make-gate-combinator gate) 124 | (lambda (#:line-length [ll 3] 125 | #:in1 [n1 #f] 126 | #:in2 [n2 #f] 127 | #:in3 [n3 #f] 128 | #:out [n4 #f] 129 | #:tag-in1 [tag-n1 #f] 130 | #:tag-in2 [tag-n2 #f] 131 | #:tag-in3 [tag-n3 #f] 132 | #:tag-out [tag-n4 #f]) 133 | (save 134 | (before 135 | (gate n1 n2 n3 n4) 136 | (if tag-n1 137 | (save (move-up 1) 138 | (line-left ll) 139 | (tag-location tag-n1)) 140 | nothing) 141 | (if tag-n2 142 | (save (line-left ll) 143 | (tag-location tag-n2)) 144 | nothing) 145 | (if tag-n3 146 | (save (move-down 1) 147 | (line-left ll) 148 | (tag-location tag-n3)) 149 | nothing) 150 | (if tag-n4 151 | (save (line-right ll) 152 | (tag-location tag-n4)) 153 | nothing))))) 154 | 155 | (define (not-at x y) 156 | (define s (gate-size .15)) 157 | (define p (new dc-path%)) 158 | (send p ellipse 159 | (- (gate-size (- x 1/2)) (/ s 2)) 160 | (- (gate-size (- y 1/2)) (/ s 2)) 161 | 162 | s s) 163 | p) 164 | 165 | (define or-gate-path 166 | (interpret-path-commands 167 | (parse-path-commands 168 | "M 0.61775626,0.19872161 L 0.62004791,0.20387782 C 0.62157568,0.2073153 0.62253054,0.21017987 0.62291248,0.21247152 C 0.62329442,0.21476317 0.62346803,0.21705482 0.62346803,0.21934647 C 0.62346803,0.22162076 0.62329442,0.22391242 0.62291248,0.22620407 C 0.62253054,0.22849572 0.62157568,0.23136029 0.62004791,0.23479776 C 0.61852015,0.23823524 0.61775626,0.23995398 0.61775626,0.23995398 C 0.61775626,0.23995398 0.62004791,0.23995398 0.62463122,0.23995398 C 0.62921452,0.23995398 0.632652,0.23995398 0.63494365,0.23995398 C 0.63721794,0.23995398 0.64013459,0.23976301 0.64367624,0.23938107 C 0.64720052,0.23899913 0.65082897,0.23804427 0.65456158,0.2365165 C 0.65827684,0.23498874 0.66166223,0.23309639 0.66471777,0.23080473 C 0.6677733,0.22851308 0.67025593,0.22603046 0.67216564,0.22335686 C 0.67407535,0.22068327 0.6750302,0.21934647 0.6750302,0.21934647 C 0.6750302,0.21934647 0.67407535,0.21800968 0.67216564,0.21533608 C 0.67025593,0.21266249 0.6677733,0.21017987 0.66471777,0.20788821 C 0.66166223,0.20561392 0.65827684,0.20368685 0.65456158,0.20217645 C 0.65082897,0.20064868 0.64720052,0.19969382 0.64367624,0.19931188 C 0.64015195,0.19892994 0.63723531,0.19873897 0.63494365,0.19873897 C 0.632652,0.19873897 0.62921452,0.19873897 0.62463122,0.19873897 L 0.61775626,0.19872161 z "))) 169 | (define and-gate-path 170 | (interpret-path-commands 171 | (parse-path-commands 172 | "M 0.62119374,0.033722662 C 0.63150617,0.033722662 0.64181861,0.033722662 0.65213104,0.033722662 C 0.65365881,0.033722662 0.65537755,0.033913633 0.65728726,0.034295575 C 0.65919697,0.034677517 0.66110668,0.035441401 0.66299903,0.036587227 C 0.66490874,0.037715692 0.66681845,0.039451792 0.66872816,0.041726083 C 0.67063787,0.044017735 0.67197467,0.04670869 0.67273855,0.049746865 C 0.67350243,0.052802401 0.67350243,0.055857937 0.67273855,0.058913473 C 0.67197467,0.061969009 0.67063787,0.064642603 0.66872816,0.066934255 C 0.66681845,0.069208546 0.66490874,0.070927285 0.66299903,0.072090472 C 0.66110668,0.073218937 0.65919697,0.073982821 0.65728726,0.074364763 C 0.65537755,0.074746705 0.65365881,0.074937676 0.65213104,0.074937676 C 0.65060328,0.074937676 0.64506512,0.074937676 0.63551657,0.074937676 C 0.62596802,0.074937676 0.62119374,0.074937676 0.62119374,0.074937676 C 0.62119374,0.074937676 0.62119374,0.06806272 0.62119374,0.054312808 L 0.62119374,0.033722662 z "))) 173 | (define buffer-gate-path 174 | (let () 175 | (define path (new dc-path%)) 176 | ;; the actual path 177 | (send path move-to 0 1/8) 178 | (send path line-to 0 7/8) 179 | (send path line-to 1 1/2) 180 | (send path close) 181 | path)) 182 | (define register-gate-path 183 | (let () 184 | (define p (new dc-path%)) 185 | (send* p 186 | (move-to 0 0) 187 | (line-to 0 1) 188 | (line-to 1 1) 189 | (line-to 1 0) 190 | (line-to 0 0) 191 | (close) 192 | (move-to .25 1) 193 | (line-to .5 .75) 194 | (line-to .75 1) 195 | (line-to .25 1) 196 | (close)) 197 | p)) 198 | 199 | 200 | (define and-gate 201 | (make-gate-combinator 202 | (make-gate-pict-maker and-gate-path 0 0 0))) 203 | (define or-gate 204 | (make-gate-combinator 205 | (make-gate-pict-maker or-gate-path 1/24 1/12 1/24))) 206 | (define register 207 | (make-gate-combinator 208 | (make-gate-pict-maker register-gate-path 0 0 0 209 | #:fill? #t))) 210 | (define buffer 211 | (make-gate-combinator 212 | (make-gate-pict-maker buffer-gate-path 0 0 0 213 | #:override-path-width 1 214 | #:override-path-height 1 215 | #:override-path-left 0 216 | #:override-path-top 0))) -------------------------------------------------------------------------------- /diagrama-lib/diagrama/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract) 3 | (provide 4 | for/after for*/after 5 | for/*> for*/*> 6 | for/<* for*/<* 7 | (contract-out 8 | [diagram? predicate/c] 9 | [to-coord (-> positive? real? real?)] 10 | [units (-> positive? diagram?)] 11 | [color (-> (or/c string? (is-a?/c color%)) 12 | diagram?)] 13 | [line-width (-> (real-in 0 255) diagram?)] 14 | [img 15 | (->* (pict-convertible?) 16 | ((or/c 'lt 'ct 'rt 'lc 'cc 'rc 'lb 'cb 'rb)) 17 | diagram?)] 18 | [path (->* ((is-a?/c dc-path%)) 19 | ((or/c 'odd-even 'winding)) 20 | diagram?)] 21 | [move-to (-> real? real? diagram?)] 22 | [tag-location 23 | (->i ([_ any/c]) 24 | ([x real?] 25 | [y real?]) 26 | #:pre/name (x y) 27 | "May not give only one of X and Y" 28 | (equal? (equal? x the-unsupplied-arg) (equal? y the-unsupplied-arg)) 29 | [_ diagram?])] 30 | [move-right (-> real? diagram?)] 31 | [move-left (-> real? diagram?)] 32 | [move-down (-> real? diagram?)] 33 | [move-up (-> real? diagram?)] 34 | [move-to-tag (-> any/c diagram?)] 35 | [line-to (->* (real? real?) 36 | (#:h-first any/c) 37 | diagram?)] 38 | [line-left (-> real? diagram?)] 39 | [line-right (-> real? diagram?)] 40 | [line-down (-> real? diagram?)] 41 | [line-up (-> real? diagram?)] 42 | [line-to-tag (->* (any/c) 43 | (#:h-first any/c) 44 | diagram?)] 45 | [save (-> diagram? ... diagram?)] 46 | [save/bounds (-> diagram? ... diagram?)] 47 | [after (-> diagram? ... diagram?)] 48 | [before (-> diagram? diagram? ... diagram?)] 49 | [<* (-> diagram? diagram? ... diagram?)] 50 | [*> (-> diagram? diagram? ... diagram?)] 51 | [split (-> diagram? diagram? diagram?)] 52 | [label (-> (or/c string? 53 | pict-convertible?) 54 | (or/c 'up 'down 'left 'right) diagram?)] 55 | [nothing diagram?] 56 | 57 | [pin-here 58 | (-> diagram? any/c diagram?)] 59 | 60 | [with-loc (-> 61 | (-> real? real? diagram?) 62 | diagram?)] 63 | [with-bounds 64 | (-> 65 | (-> real? real? real? real? diagram?) 66 | diagram?)] 67 | [with-unit 68 | (-> (-> real? diagram?) diagram?)] 69 | [with-line-width 70 | (-> (-> (real-in 0 255) diagram?) diagram?)] 71 | [with-color 72 | (-> (-> (or/c string? (is-a?/c color%)) diagram?) 73 | diagram?)] 74 | [with-locations-of 75 | (-> any/c ... procedure? 76 | diagram?)] 77 | [start-at (-> #:ud (or/c 'up 'down) #:lr (or/c 'left 'right) 78 | diagram? ... 79 | diagram?)] 80 | [line-between 81 | (-> any/c any/c diagram?)] 82 | [unit-grid diagram?])) 83 | (require pict racket/draw pict/convert 84 | "private/shared.rkt" 85 | racket/match 86 | racket/class 87 | racket/list 88 | racket/math 89 | (for-syntax racket/base syntax/parse)) 90 | 91 | (define (tag-location tag [x #f] [y #f]) 92 | (after 93 | (if x (move-to x y) nothing) 94 | (diagram 95 | (lambda (state) 96 | (values 97 | void 98 | (if tag (state-add-tag state tag) state)))))) 99 | 100 | (define (units u) 101 | (diagram 102 | (lambda (s) 103 | (values void (state-set-unit s u))))) 104 | 105 | (define (color c) 106 | (diagram 107 | (lambda (s) 108 | (values void (state-set-color s c))))) 109 | 110 | (define (line-width lw) 111 | (diagram 112 | (lambda (s) 113 | (values void (state-set-line-width s lw))))) 114 | 115 | (define (line-right x) 116 | (diagram 117 | (lambda (state) 118 | ((line-to (+ (diagram-state-x state) x) 119 | (diagram-state-y state)) 120 | state)))) 121 | 122 | (define (line-down y) 123 | (diagram 124 | (lambda (state) 125 | ((line-to (diagram-state-x state) (+ (diagram-state-y state) y)) 126 | state)))) 127 | (define (line-left x) 128 | (line-right (- x))) 129 | (define (line-up x) 130 | (line-down (- x))) 131 | 132 | (define (line-to-tag tag #:h-first [h #t]) 133 | (diagram 134 | (lambda (state) 135 | ((apply line-to #:h-first h (hash-ref (diagram-state-coord-tags state) tag)) 136 | state)))) 137 | 138 | (define (line-to x y #:h-first [h-first #t]) 139 | (define (h s) 140 | ((line-to* (- x (diagram-state-x s)) 0) s)) 141 | (define (v s) 142 | ((line-to* 0 (- y (diagram-state-y s))) s)) 143 | (diagram 144 | (lambda (state) 145 | (define-values (d s) ((if h-first h v) state)) 146 | (define-values (d2 s2) ((if h-first v h) s)) 147 | (values (lambda (dc) (d dc) (d2 dc)) 148 | s2)))) 149 | 150 | (define (line-to* x y) 151 | (define p (new dc-path%)) 152 | (send p move-to 0 0) 153 | (send p line-to x y) 154 | (send p close) 155 | (path p)) 156 | 157 | (define (path p* [fill-mode 'odd-even]) 158 | (define p (new dc-path%)) 159 | (send p append p*) 160 | (send p close) 161 | (define-values (ps _) (send p get-datum)) 162 | (define-values (x y) 163 | (match (filter (lambda (x) (not (empty? x))) ps) 164 | [(list) (values 0 0)] 165 | [(list _ ... (list _ ... (vector _ ... x y))) 166 | (values x y)])) 167 | (define-values (x0 y0 w h) (send p get-bounding-box)) 168 | (define xm (+ w x0)) 169 | (define ym (+ h y0)) 170 | (diagram 171 | (lambda (s) 172 | (match-define (diagram-state x1 y1 vx vy ^x ^y unit lw c tags) s) 173 | (values 174 | (draw-path-with-drawing-state p s fill-mode) 175 | (diagram-state 176 | (+ x x1) (+ y y1) 177 | (min vx (+ x0 x1)) 178 | (min vy (+ y0 y1)) 179 | (max ^x (+ xm x1)) 180 | (max ^y (+ ym y1)) 181 | unit lw c 182 | tags))))) 183 | 184 | (define (draw-path-with-drawing-state p state fill-mode) 185 | (lambda (dc) 186 | (define p2 (new dc-path%)) 187 | (send p2 append p) 188 | (send p2 close) 189 | (match-define 190 | (struct* diagram-state 191 | ([x sx] [y sy] [unit unit] [color c] [line-width lw])) 192 | state) 193 | (define pen (send dc get-pen)) 194 | (define m (send dc get-transformation)) 195 | (send dc set-pen c lw 'solid) 196 | (send p2 transform 197 | (vector unit 0 198 | 0 unit 199 | (to-coord unit sx) (to-coord unit sy))) 200 | (send dc draw-path p2 0 0 fill-mode) 201 | (send dc set-pen pen) 202 | (send dc set-transformation m))) 203 | 204 | 205 | (define (move-right x) 206 | (diagram 207 | (lambda (state) 208 | ((move-to (+ x (diagram-state-x state)) (diagram-state-y state)) 209 | state)))) 210 | (define (move-down y) 211 | (diagram 212 | (lambda (state) 213 | ((move-to (diagram-state-x state) (+ y (diagram-state-y state))) 214 | state)))) 215 | (define (move-left x) 216 | (move-right (- x))) 217 | (define (move-up x) 218 | (move-down (- x))) 219 | 220 | (define (move-to-tag tag) 221 | (diagram 222 | (lambda (state) 223 | ((apply move-to (hash-ref (diagram-state-coord-tags state) tag)) 224 | state)))) 225 | 226 | (define (move-to x y) 227 | (diagram 228 | (lambda (state) 229 | (values 230 | void 231 | (move-state-to state x y))))) 232 | 233 | (define (img pict [align 'cc]) 234 | (define-values (horz vert) 235 | (let ([v (symbol->string align)]) 236 | (values 237 | (string->symbol (string (string-ref v 0))) 238 | (string->symbol (string (string-ref v 1)))))) 239 | (define w (pict-width pict)) 240 | (define h (pict-height pict)) 241 | 242 | (diagram 243 | (lambda (state) 244 | (match-define (diagram-state x y vx vy ^x ^y unit lw c tags) state) 245 | (define x* 246 | (- x 247 | (case horz 248 | [(l) 0] 249 | [(c) (/ w (* unit 2))] 250 | [(r) (/ w unit)]))) 251 | (define y* 252 | (- y 253 | (case vert 254 | [(t) 0] 255 | [(c) (/ h (* unit 2))] 256 | [(b) (/ h unit)]))) 257 | (values 258 | (pict-drawer pict state x* y*) 259 | (diagram-state 260 | x y 261 | (min vx (exact-round x*)) 262 | (min vy (exact-round y*)) 263 | (max ^x (exact-round (+ x* (/ w unit)))) 264 | (max ^y (exact-round (+ y* (/ h unit)))) 265 | unit lw c 266 | tags))))) 267 | 268 | 269 | (define (pict-drawer pict s x y) 270 | (define u (diagram-state-unit s)) 271 | (lambda (dc) 272 | (draw-pict pict dc 273 | (to-coord u x) 274 | (to-coord u y)))) 275 | 276 | (define (after . a) 277 | (match a 278 | [(list) 279 | (diagram (lambda (state) (values void state)))] 280 | [(cons f a) 281 | (define r (apply after a)) 282 | (diagram 283 | (lambda (state) 284 | (define-values (draw state1) (f state)) 285 | (define-values (draw2 state2) (r state1)) 286 | (values 287 | (lambda (dc) (draw dc) (draw2 dc)) 288 | state2)))])) 289 | 290 | (define (<* f . a) 291 | (if (empty? a) 292 | f 293 | (diagram 294 | (lambda (state) 295 | (define-values (draw state1) (f state)) 296 | (define-values (draw2 state2) 297 | ((apply <* a) 298 | (state-set-unit 299 | (move-state-to state1 (diagram-state-x state) (diagram-state-y state)) 300 | (diagram-state-unit state)))) 301 | (values 302 | (lambda (dc) (draw dc) (draw2 dc)) 303 | (move-state-to 304 | state2 305 | (diagram-state-x state1) 306 | (diagram-state-y state1))))))) 307 | 308 | (define (*> f . a) 309 | (if (empty? a) 310 | f 311 | (diagram 312 | (lambda (state) 313 | (define-values (draw state1) (f state)) 314 | (define-values (draw2 state2) 315 | ((apply *> a) 316 | (state-set-unit 317 | (move-state-to state1 (diagram-state-x state) (diagram-state-y state)) 318 | (diagram-state-unit state)))) 319 | (values 320 | (lambda (dc) (draw dc) (draw2 dc)) 321 | state2))))) 322 | 323 | (define nothing 324 | (diagram (lambda (state) (values void state)))) 325 | 326 | (define (with-state thunk) 327 | (diagram 328 | (lambda (s) 329 | ((thunk s) s)))) 330 | 331 | (define (save/bounds . thunks) 332 | (define f (apply after thunks)) 333 | (diagram 334 | (lambda (s) 335 | (define-values (d s2) (f s)) 336 | (match-define (diagram-state x y x0 y0 xm ym unit lw c hash) s) 337 | (values d 338 | (diagram-state x y x0 y0 xm ym unit lw c 339 | (diagram-state-coord-tags s2)))))) 340 | 341 | (define (pin-here other tag) 342 | ;; this is horribly slow. sorry, don't care atm 343 | (define-values (_ other-state) 344 | ((diagram-f other) (new-state 0 0))) 345 | (match-define (list ox oy) (state-get-tag other-state tag)) 346 | (after 347 | (move-left ox) 348 | (move-up oy) 349 | other)) 350 | 351 | 352 | 353 | ; 354 | ; 355 | ; 356 | ; ;; ; 357 | ; ;;;;;; ;; ;; 358 | ; ;; ;; ;; 359 | ; ;; ;; ;; 360 | ; ;; ; ;;;; ;; ;;; ;;;; ;; ; ;;;; ;;; ;; 361 | ; ;; ; ;; ;; ; ; ; ; ; ;; ;; ;; ;; ;;; 362 | ; ;; ; ; ;; ;; ; ; ; ; ; ;; ;; ;; 363 | ; ;; ; ;; ;; ;; ; ;; ; ;; ;; ;; ;; 364 | ; ;; ; ;;;;;;;; ;; ; ; ;; ;;;;;;;; ;; ;; 365 | ; ;; ;; ;; ;; ; ; ; ;; ;; ;; 366 | ; ;; ;; ; ;; ; ;; ; ; ;; ;; 367 | ; ;; ;; ;; ; ;; ; ;; ;; ; ;; ;;; 368 | ; ;;;;;; ;;;;;; ;;;; ;;;;;;; ;; ;;;;;; ;;; ;; 369 | ; 370 | ; 371 | ; 372 | ; 373 | ; 374 | 375 | 376 | (define (save . thunks) 377 | (*> (apply after thunks) nothing)) 378 | 379 | (define (with-loc thunk) 380 | (with-state 381 | (lambda (s) 382 | (thunk (diagram-state-x s) (diagram-state-y s))))) 383 | (define (with-bounds thunk) 384 | (with-state 385 | (lambda (s) 386 | (match-define 387 | (struct* diagram-state 388 | ([min-x x0] [min-y y0] [max-x xm] [max-y ym])) 389 | s) 390 | (thunk x0 y0 xm ym)))) 391 | 392 | (define (with-unit thunk) 393 | (with-state 394 | (lambda (s) 395 | (thunk (diagram-state-unit s))))) 396 | 397 | (define (with-color thunk) 398 | (with-state 399 | (lambda (s) 400 | (thunk (diagram-state-color s))))) 401 | (define (with-line-width thunk) 402 | (with-state 403 | (lambda (s) 404 | (thunk (diagram-state-line-width s))))) 405 | 406 | (define (with-locations-of . args) 407 | (define a (reverse args)) 408 | (define thunk (first a)) 409 | (define tags (reverse (rest a))) 410 | (with-state 411 | (lambda (s) 412 | (apply thunk 413 | (append-map 414 | (lambda (tag) 415 | (hash-ref (diagram-state-coord-tags s) tag)) 416 | tags))))) 417 | 418 | (define (start-at #:ud ud #:lr lr . b) 419 | (for/fold ([p nothing]) 420 | ([h (in-list (reverse b))]) 421 | (after h 422 | (with-bounds 423 | (lambda (x0 y0 xm ym) 424 | (after 425 | (move-to 426 | (case lr 427 | [(left) x0] 428 | [(right) xm]) 429 | (case ud 430 | [(up) y0] 431 | [(down) ym])) 432 | p)))))) 433 | 434 | (define (before a . f) 435 | (<* (apply after f) 436 | a)) 437 | 438 | (define (label t dir) 439 | (save 440 | (after 441 | ((case dir 442 | [(up) move-up] 443 | [(down) move-down] 444 | [(right) move-right] 445 | [(left) move-left]) 446 | 1) 447 | (img 448 | (if (pict? t) 449 | t 450 | (text t)))))) 451 | 452 | (define (cwhen c . p) 453 | (if c 454 | (apply after p) 455 | nothing)) 456 | 457 | (define (dot lw) 458 | (img (disk (* 5 lw)))) 459 | 460 | (define (split thunk1 thunk2) 461 | (after 462 | (with-line-width dot) 463 | (save thunk1) 464 | thunk2)) 465 | 466 | (define (line-between a b #:h-first [h-fit #t]) 467 | (save 468 | (move-to-tag a) 469 | (line-to-tag b #:h-first h-fit))) 470 | 471 | (define unit-grid 472 | (with-bounds 473 | (lambda (x0 y0 xm ym) 474 | (define w (add1 (- xm x0))) 475 | (define h (add1 (- ym y0))) 476 | (save/bounds 477 | (color (make-object color% 128 128 128 .5)) 478 | (for*/after ([x (in-range (add1 w))]) 479 | (after (move-to (- (+ x x0) 1/2) (- y0 1/2)) 480 | (line-down h))) 481 | (for*/after ([y (in-range (add1 h))]) 482 | (after (move-to (- x0 1/2) (- (+ y y0) 1/2)) 483 | (line-right w))))))) 484 | 485 | 486 | 487 | 488 | ; 489 | ; 490 | ; 491 | ; ;;;;;;; ;; 492 | ; ;; ;; 493 | ; ;; ;; 494 | ; ;; ;;;; ;; ;; ;; ;;;; ;;;; ; ;;; ;;;; 495 | ; ;; ;; ;; ; ; ; ;; ;; ;; ;; ;; ;; ;; ; ; 496 | ; ;; ;; ; ;; ; ;; ;; ; ;; ; ; ; ; 497 | ; ;;;;;; ;; ; ;; ;; ;; ; ;; ; ; ; ;; 498 | ; ;; ;; ; ; ;; ;; ; ;; ; ; ; ;;;; 499 | ; ;; ;; ; ; ;; ;; ; ;; ; ; ; ;; 500 | ; ;; ;; ; ; ;; ;; ; ;; ; ; ; ; 501 | ; ;; ;; ;; ; ;; ;; ;; ;; ;; ;; ;; ;; ;; 502 | ; ;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;; ;;;;; 503 | ; ; 504 | ; ; 505 | ; ; 506 | ; 507 | ; 508 | 509 | 510 | (define-for-syntax (make-for-folder func folder) 511 | (with-syntax ([f func] [fold folder]) 512 | (syntax-parser 513 | [(_ clauses body ... final) 514 | #`(fold #,this-syntax 515 | ([p nothing]) 516 | clauses 517 | body ... 518 | (f p final))]))) 519 | (define-for-syntax (make-for-folders func) 520 | (values (make-for-folder func #'for/fold/derived) 521 | (make-for-folder func #'for*/fold/derived))) 522 | 523 | (define-syntaxes (for/after for*/after) 524 | (make-for-folders #'after)) 525 | 526 | (define-syntaxes (for/*> for*/*>) 527 | (make-for-folders #'*>)) 528 | 529 | (define-syntaxes (for/<* for*/<*) 530 | (make-for-folders #'<*)) 531 | 532 | -------------------------------------------------------------------------------- /diagrama-lib/diagrama/private/shared.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide 3 | (struct-out diagram) 4 | (struct-out diagram-state) 5 | unit 6 | to-coord 7 | new-state 8 | move-state-to 9 | state-add-tag 10 | state-get-tag 11 | state-set-unit 12 | state-set-color 13 | state-set-line-width) 14 | (require pict/convert pict racket/match racket/draw racket/class 15 | file/convertible) 16 | 17 | (struct diagram (f) 18 | #:property prop:procedure (struct-field-index f) 19 | #:property prop:pict-convertible 20 | (lambda (x) (draw-diagram (diagram-f x))) 21 | #:property prop:convertible 22 | (lambda (v r d) 23 | (convert (pict-convert v) r d))) 24 | 25 | (define (draw-diagram c) 26 | (define-values (draw state) (c (new-state 0 0))) 27 | (match-define 28 | (diagram-state x y min-x min-y max-x max-y unit _ _ _) 29 | state) 30 | (define margin (+ 2 unit)) 31 | (define w (- max-x min-x)) 32 | (define h (- max-y min-y)) 33 | (dc 34 | (lambda (dc dx dy) 35 | (define m (send dc get-transformation)) 36 | (send dc set-smoothing 'smoothed) 37 | (send dc translate 38 | (+ dx (to-coord unit (- min-x))) 39 | (+ dy (to-coord unit (- min-y)))) 40 | (draw dc) 41 | (send dc set-transformation m)) 42 | (+ margin (to-coord unit w)) 43 | (+ margin (to-coord unit h)))) 44 | 45 | (define unit 12) 46 | 47 | (define (to-coord unit m) 48 | (+ (* m unit) (/ unit 2))) 49 | 50 | (struct diagram-state 51 | (x y min-x min-y max-x max-y unit line-width color coord-tags) 52 | #:transparent) 53 | 54 | (define (new-state x y) 55 | (diagram-state x y x y x y unit 1 "black" (hash))) 56 | 57 | (define (move-state-to s x y) 58 | (match-define (diagram-state _ _ vx vy ^x ^y unit lw c tags) s) 59 | (diagram-state x y 60 | (min x vx) (min y vy) 61 | (max x ^x) (max y ^y) 62 | unit lw c 63 | tags)) 64 | (define (state-add-tag s t) 65 | (match-define (diagram-state x y vx vy ^x ^y unit lw c tags) s) 66 | (diagram-state x y vx vy ^x ^y 67 | unit lw c 68 | (hash-set tags t (list x y)))) 69 | 70 | (define (state-get-tag s t) 71 | (hash-ref (diagram-state-coord-tags s) t)) 72 | 73 | (define (state-set-unit s u) 74 | (match-define (diagram-state x y vx vy ^x ^y _ lw c tags) s) 75 | (diagram-state x y vx vy ^x ^y 76 | u lw c 77 | tags)) 78 | 79 | (define (state-set-color s c) 80 | (match-define (diagram-state x y vx vy ^x ^y u lw _ tags) s) 81 | (diagram-state x y vx vy ^x ^y 82 | u lw c 83 | tags)) 84 | 85 | (define (state-set-line-width s lw) 86 | (match-define (diagram-state x y vx vy ^x ^y u _ c tags) s) 87 | (diagram-state x y vx vy ^x ^y 88 | u lw c 89 | tags)) -------------------------------------------------------------------------------- /diagrama-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps 6 | '("draw-lib" 7 | ("base" #:version "7.4") 8 | "pict-lib")) 9 | 10 | 11 | (define build-deps '()) 12 | 13 | (define pkg-desc "Implementation part of `diagrama`") 14 | 15 | (define version "0.1") 16 | -------------------------------------------------------------------------------- /diagrama/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps 6 | '(("base" #:version "7.4") 7 | "diagrama-lib" 8 | "diagrama-doc")) 9 | 10 | (define build-deps '()) 11 | 12 | (define pkg-desc "Implementation and Documentation part of `diagrama`") 13 | 14 | (define version "0.1") 15 | --------------------------------------------------------------------------------