#lang scheme/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
         (only-in 2htdp/private/image-more save-image))

(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-print 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))
         (save-image result (build-path "img" fn)))]
      [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)
   (error 'image-gen "didn't find any images; probably this means that you need to delete .zo files and try again")]
  [else
   (printf "\n")])

(call-with-output-file "image-toc.ss"
  (λ (port)
    (fprintf port "#lang scheme/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-print
     `(define mapping (list ,@mapping))
     port))
  #:exists 'truncate)