114 lines
3.9 KiB
Racket
114 lines
3.9 KiB
Racket
#lang racket/gui
|
|
|
|
;; Run this file is generate the images in the img/ directory,
|
|
;; picked up by image-examples from image.scrbl
|
|
|
|
(require 2htdp/image
|
|
lang/posn
|
|
racket/runtime-path)
|
|
|
|
(define-runtime-path image.scrbl "image.scrbl")
|
|
(define-runtime-path img "img")
|
|
|
|
(define-namespace-anchor anchor)
|
|
(define ns (namespace-anchor->namespace anchor))
|
|
(define expressions
|
|
(parameterize ([current-namespace ns])
|
|
(putenv "PLTSHOWIMAGES" "show")
|
|
(let-values ([(in out) (make-pipe)])
|
|
(thread
|
|
(λ ()
|
|
(parameterize ([current-output-port out])
|
|
(dynamic-require image.scrbl #f))
|
|
(close-output-port out)))
|
|
(let loop ()
|
|
(let ([exp (read in)])
|
|
(if (eof-object? exp)
|
|
'()
|
|
(cons exp (loop))))))))
|
|
|
|
(define-namespace-anchor image-anchor)
|
|
(define image-ns (namespace-anchor->namespace anchor))
|
|
|
|
(define mapping '())
|
|
|
|
(define (handle-image exp)
|
|
(printf ".") (flush-output)
|
|
(let ([result
|
|
(with-handlers ([exn:fail?
|
|
(λ (x)
|
|
(printf "\nerror evaluating:\n")
|
|
(pretty-write exp)
|
|
(raise x))])
|
|
(parameterize ([current-namespace image-ns]) (eval exp)))])
|
|
(cond
|
|
[(image? result)
|
|
(let ([fn (exp->filename exp)])
|
|
(set! mapping (cons `(list ',exp 'image ,fn) mapping))
|
|
(let ([pth (build-path img fn)])
|
|
(unless (save-image result pth)
|
|
(fprintf (current-error-port) "failed to save ~s\n" pth))))]
|
|
[else
|
|
(unless (equal? result (read/write result))
|
|
(error 'handle-image "expression ~s produced ~s, which I can't write"
|
|
exp result))
|
|
(set! mapping (cons `(list ',exp 'val ,result) mapping))])))
|
|
|
|
(define (exp->filename exp)
|
|
(let loop ([prev 0])
|
|
(let ([candidate
|
|
(format "~a~a.png"
|
|
(number->string (exp->number exp) 16) ;; abs to avoid filenames beginning with hyphens
|
|
(if (zero? prev)
|
|
""
|
|
(format "-~a" (number->string prev 16))))])
|
|
(cond
|
|
[(anywhere? candidate mapping)
|
|
(printf "dup!\n")
|
|
(loop (+ prev 1))]
|
|
[else
|
|
candidate]))))
|
|
|
|
(define (anywhere? x sexp)
|
|
(let loop ([sexp sexp])
|
|
(cond
|
|
[(pair? sexp) (or (loop (car sexp))
|
|
(loop (cdr sexp)))]
|
|
[else (equal? x sexp)])))
|
|
|
|
;(define a-prime (- (expt 2 127) 1)) ;; Lucas found this in 1876. (too long filenames)
|
|
(define a-prime (/ (- (expt 2 59) 1) 179951)) ;; found by Landry in 1867
|
|
;(define a-prime 113) ;; has too many collisions
|
|
(define base 256)
|
|
|
|
(define (exp->number exp)
|
|
(let ([digits (map char->integer (string->list (format "~s" exp)))])
|
|
(when (ormap (λ (x) (not (<= 0 x (- base 1)))) digits)
|
|
(error 'exp->number "found a char that was bigger than ~a in ~s" (- base 1) exp))
|
|
(let loop ([n 1]
|
|
[digits digits])
|
|
(cond
|
|
[(null? digits) (modulo n a-prime)]
|
|
[else (loop (+ (car digits) (* n base))
|
|
(cdr digits))]))))
|
|
|
|
(define (read/write result)
|
|
(let-values ([(in out) (make-pipe)])
|
|
(thread (λ () (write result out) (close-output-port out)))
|
|
(read in)))
|
|
|
|
(for-each handle-image expressions)
|
|
(cond
|
|
[(null? mapping)
|
|
(printf "image-gen: didn't find any images; probably this means that you need to delete .zo files and try again\n")]
|
|
[else
|
|
(printf "\n")
|
|
(call-with-output-file "image-toc.rkt"
|
|
(λ (port)
|
|
(fprintf port "#lang racket/base\n(provide mapping)\n")
|
|
(fprintf port ";; this file is generated by image-gen.ss -- do not edit\n;; note that the file that creates this file depends on this file\n;; it is always safe to simply define (and provide) mapping as the empty list\n\n")
|
|
(pretty-write
|
|
`(define mapping (list ,@mapping))
|
|
port))
|
|
#:exists 'truncate)])
|