bdeket · January 5, 2022 01:26
diff --git a/autostereo.rkt b/autostereo.rkt
 #lang typed/racket/base

 (require images/flomap
         (only-in math/flonum flvector flvector-length make-flvector flvector-set! flhypot fl)
         (only-in racket/flonum in-flvector)
         racket/math
         typed/racket/class
         (only-in typed/racket/draw bitmap%))

 (provide (except-out (all-defined-out)
                     fill-stereo-flvector!
                     fill-look-info-flvector!))

 ;***************************************************************************************************
 ;* Data structs & helpers                                                                          *
 ;***************************************************************************************************
 ;; Depth contains the depth information of the 3d object.
 ;; the at argument is a function that takes an x and y position argument and
 ;; should return a value between 0 (= black = no pop out)
 ;;                           and 1 (= white = maximum pop out)
 (struct depth ([at : (-> Nonnegative-Integer Nonnegative-Integer Real)]
               [width : Positive-Integer]
               [height : Positive-Integer])
  #:transparent
  #:type-name Depth)

 ;; pattern contains information for creating a repeatable tile
 ;; the at argument is a function that takes an x and y position argument and
 ;; shoud return a FlVector (size 1 to 4) containing the color information at
 ;; that point. (the same length FlVector should be returned for all points)
 (struct pattern ([at : (-> Nonnegative-Integer Nonnegative-Integer FlVector)]
                [width : Positive-Integer]
                [height : Positive-Integer])
  #:transparent
  #:type-name pattern)

 ;; Convert a flomap-image to a pattern
 (define (flomap->pattern [F : flomap])
  (pattern (λ ([x : Nonnegative-Integer][y : Nonnegative-Integer]) (flomap-ref* F x y))
          (cast (flomap-width F) Positive-Integer)
          (cast (flomap-height F) Positive-Integer)))

 ;; convert a depth element to a bitmap
 (define (depth->bitmap [D : Depth])
  (flomap->bitmap
   (build-flomap 1 (depth-width D)(depth-height D)
                 (λ (k [x : Nonnegative-Integer][y : Nonnegative-Integer])
                   ((depth-at D) x y)))))

 ;; convert a pattern to a bitmap
 (define (pattern->bitmap [P : pattern])
  (define c (flvector-length ((pattern-at P) 0 0)))
  (flomap->bitmap
   (build-flomap* c (pattern-width P)(pattern-height P)
                 (λ ([x : Nonnegative-Integer][y : Nonnegative-Integer])
                   ((pattern-at P) x y)))))

 ;***************************************************************************************************
 ;* Other helpers                                                                                   *
 ;***************************************************************************************************
 ;; Create a random pattern
 (define (make-random-pattern [width : Positive-Integer 100]
                            [height : Positive-Integer width]
                            #:components [c : Positive-Byte 3]) : pattern
  (unless (<= 1 c 4) (raise-argument-error 'make-random-pattern "(U 1 2 3 4)" c))
  (define P (build-flomap* c width height (λ any (build-vector c (λ (i)(random))))))
  (pattern (λ ([x : Nonnegative-Integer][y : Nonnegative-Integer])
            (flomap-ref* P x y))
          width height))

 ;; Create a checkers-board pattern
 (define (checkers-pattern [size : Positive-Integer][number : Positive-Integer])
  (define M (* 2 size))
  (define N (* M number))
  (pattern (λ ([x : Nonnegative-Integer][y : Nonnegative-Integer])
            (flvector
             (if (< (modulo x M) size)
                 (if (< (modulo y M) size) 1. 0.)
                 (if (< (modulo y M) size) 0. 1.))))
          N N))

 ;; Check if a point is in a circle
 (define (make-in-circle? [R : Real][cx : Real 0][cy : Real 0])
    (define R² (expt R 2))
    (λ ([x : Real][y : Real])
      (< (+ (expt (- x cx) 2)
            (expt (- y cy) 2))
         R²)))

 ;; Check the distance from a point to a line
 (define (make-from-line [x1 : Real][y1 : Real][x2 : Real][y2 : Real])
    (λ ([x : Real][y : Real])
      (/ (+ (* (- y1 y2) (- x x1))(* (- x2 x1) (- y y1)) 0)
         (flhypot (fl (- y2 y1)) (fl (- x2 x1))))))

 ;***************************************************************************************************
 ;* Autostereograms                                                                                 *
 ;***************************************************************************************************
 ;; Create an autostereogram (flomap)
 ;; #:depth: (mandatory) the 3d image to embed in the autostereogram
 ;; #:pattern: the tile to use for the background (default to random-pattern)
 ;; #;max-depth: specifies how far the 3d image can pop out. If this value is to big, the
 ;;              autostereographic effect will not work. (max = pattern-width)
 ;;              Best is to keep it below 25% of the pattern width. (= default)
 ;; #:looking-info?: add 2 dots above the image to show the distance for the pattern (default is #f)
 ;; #:type: create the autostereogram for cross-eyed, or parallel looking (default is parallel)

 (define (autostereogram #:depth [D : Depth]
                        #:pattern [P : pattern (make-random-pattern (ceiling (* (depth-width D) 1/5)))]
                        #:max-depth [max-depth : Positive-Integer (ceiling (* (pattern-width P) 1/8))]
                        #:looking-info? [li? : Boolean #t]
                        #:type [type : (U 'cross 'parallel) 'parallel]) : flomap
  (when (< (pattern-width P) max-depth)
    (raise-argument-error 'autostereogram
                          (format "max-depth smaller than pattern width (~a)" (pattern-width P))
                          max-depth))
  (define li-height 20)
  (define c (flvector-length ((pattern-at P) 0 0)))
  (define width (depth-width D))
  (define height (depth-height D))
  (define total-height (+ height (if li? li-height 0)))
  (define fl (make-flvector (* c width total-height)))

  (when li?
    (fill-look-info-flvector! fl width height
                              (pattern-width P) li-height total-height
                              c (eq? type 'cross)))
  
  (fill-stereo-flvector! fl D P width height c max-depth)

  (flomap fl c width total-height))

 (: fill-stereo-flvector!
   (->  FlVector Depth pattern Positive-Integer Positive-Integer Index Positive-Integer
       Void))
 (define (fill-stereo-flvector! fl D P width height c max-depth)
  (for* ([yi : Nonnegative-Integer (in-range height)]
         [xi : Nonnegative-Integer (in-range width)])
    (define Ii (coords->index c width 0 xi yi))
    (define xd (- xi (- (pattern-width P)
                        (exact-round (* ((depth-at D) xi yi) max-depth)))))

    (for ([vj (if (< xd (pattern-width P))
                  (in-flvector ((pattern-at P) (modulo xd (pattern-width P))
                                              (modulo yi (pattern-height P))))
                  (let ([index (coords->index c width 0 xd yi)])
                    (in-flvector fl index (+ index c))))]
          [j (in-naturals)])
      (flvector-set! fl (+ Ii j) vj)
      'done-aRGB)
    'done-pixel))

 (: fill-look-info-flvector!
   (-> FlVector Positive-Integer Positive-Integer Positive-Integer Positive-Integer Positive-Integer Index Boolean
       Void))
 (define (fill-look-info-flvector! fl width height p-width li-height total-height c cross?)
  (define R (* li-height .25))
  (define h/2 (+ height (/ li-height 2)))
  (define in-c1? (make-in-circle? R (/ (- width p-width) 2) h/2))
  (define in-c2? (make-in-circle? R (/ (+ width p-width) 2) h/2))
  (define Cx (- width li-height))
  (define ym (+ height 2))
  (define l1 (make-from-line (- Cx (* 1.5 R)) ym ((if cross? + -) Cx (* 1.5 R)) total-height))
  (define l2 (make-from-line (+ Cx (* 1.5 R)) ym ((if cross? - +) Cx (* 1.5 R)) total-height))

  (for* ([xi : Nonnegative-Integer (in-range width)]
         [yi : Nonnegative-Integer (in-range height total-height)])
    (define Ii (coords->index c width 0 xi yi))
    (for ([j (in-range c)])
      (flvector-set! fl (+ Ii j)
                     (if (or (in-c1? xi yi)
                             (in-c2? xi yi)
                             (and (< (+ height 2) yi)
                                  (or (<= (abs (l1 xi yi)) 1)
                                      (<= (abs (l2 xi yi)) 1))))
                         0.0
                         1.0)))))

 ;***************************************************************************************************
 ;* Tests and image                                                                                 *
 ;***************************************************************************************************

 (module+ test
  ;******depth maps*******
  (define circle
    (let ([in-circle1? (make-in-circle? 80 200 200)]
          [in-circle2? (make-in-circle? 90 200 200)])
      (depth (λ (x y)
             (if (in-circle2? x y)
                 (if (in-circle1? x y) 1 .5)
                 0))
           400 400))))

 (module+ test
  (depth->bitmap circle)
  (pattern->bitmap (make-random-pattern #:components 1))
  (pattern->bitmap (make-random-pattern #:components 2))
  (pattern->bitmap (make-random-pattern #:components 3))
  (pattern->bitmap (make-random-pattern #:components 4))
  (flomap->bitmap (autostereogram #:depth circle
                                  #:pattern (checkers-pattern 25 2)
                                  #:max-depth 5))
  (flomap->bitmap (autostereogram #:depth circle
                                  #:max-depth 20))
  (flomap->bitmap (autostereogram #:depth (depth (λ (x y)
                                                   (define dx (- x 200))
                                                   (define dy (- y 200))
                                                   (define r (sqrt (+ (sqr dx) (sqr dy))))
                                                   (if (< r 100) (/ (- 100 r) 100) 0))
                                                 400 400)
                                  #:max-depth 5))
  (flomap->bitmap (autostereogram #:depth (depth (λ (x y)
                                                   (define dx (- x 200))
                                                   (define dy (- y 200))
                                                   (define r (sqrt (+ (sqr dx) (sqr dy))))
                                                   (if (< r 100) (/ (- 100 r) 100) 0))
                                                 400 400)
                                  #:max-depth 10))
  (flomap->bitmap (autostereogram #:depth (depth (λ (x y)
                                                   (define dx (- x 200))
                                                   (define dy (- y 200))
                                                   (define r (sqrt (+ (sqr dx) (sqr dy))))
                                                   (if (< r 100) (/ (- 100 r) 100) 0))
                                                 400 400)
                                  #:max-depth 15))
  (flomap->bitmap (autostereogram #:depth (depth (λ (x y)
                                                   (define dx (- x 200))
                                                   (define dy (- y 200))
                                                   (define r (sqrt (+ (sqr dx) (sqr dy))))
                                                   (if (< r 100) (/ (- 100 r) 100) 0))
                                                 400 400)
                                  #:max-depth 20))
  (flomap->bitmap (autostereogram #:depth (depth (λ (x y)
                                                   (define dx (- x 200))
                                                   (define dy (- y 200))
                                                   (define r (sqrt (+ (sqr dx) (sqr dy))))
                                                   (if (< r 100) (/ (- 100 r) 100) 0))
                                                 400 400)
                                  #:pattern (checkers-pattern 20 2)
                                  #:max-depth 20)))

diff --git a/plt-logo.rkt b/plt-logo.rkt
 #lang racket/base

 (require racket/match
         racket/list
         mrlib/gif
         images/flomap
         (only-in math/flonum flvector))

 (require "autostereo.rkt")

 (define (mkgif lst name
               #:speed [speed 10]
               #:exists [exists 'error])
  (when (and (file-exists? name) (eq? exists 'replace))
    (delete-file name))
  (write-animated-gif lst speed name))

 (define transparent (flvector 0. 1. 1. 1.))
 (define white (flvector 1. 1. 1. 1.))

 ;***************************************************************************************************
 ;* Logos                                                                                           *
 ;***************************************************************************************************
 (define (plt-logo-maker x y r [ϕ 0] [d (* 0.25 r)])
    (define r* (* r 2.77425))
    (define x1 (+ x (* r (+ (* -1.92114 (cos ϕ)) (* 1.39882 (sin ϕ))))))
    (define y1 (+ y (* r (+ (*  1.92114 (sin ϕ)) (* 1.39882 (cos ϕ))))))
    (define x2 (+ x (* r (+ (*  1.91125 (cos ϕ)) (* 1.58848 (sin ϕ))))))
    (define y2 (+ y (* r (+ (* -1.91125 (sin ϕ)) (* 1.58848 (cos ϕ))))))
    (define in-c1? (make-in-circle? r        x  y))
    (define in-c2? (make-in-circle? r*       x1 y1))
    (define in-c3? (make-in-circle? (- r* d) x1 y1))
    (define in-c4? (make-in-circle? r*       x2 y2))
    (define in-c5? (make-in-circle? (- r* d) x2 y2))
    (define white (flvector 1. 1. 1. 1.))
    (define red   (flvector 1. .623529 .11375 .12549))
    (define blue  (flvector 1. .243137 .356863 .662745))
    (λ (x y)
      (if (in-c1? x y)
          (if (in-c2? x y)
              (if (in-c3? x y)
                  (if (in-c4? x y)
                      (if (in-c5? x y)
                          red
                          white)
                      red)
                  white)
              blue)
          transparent)))

 (define (plt-3dlogo-maker x0 y0 r [ϕ 0] [θ 0] [d (* 0.25 r)])
  (define r* (* r 2.77425))
  (define x1 (+ x0 (* r (+ (* -1.92114 (cos ϕ)) (* 1.39882 (sin ϕ))))))
  (define y1 (+ y0 (* r (+ (*  1.92114 (sin ϕ)) (* 1.39882 (cos ϕ))))))
  
  (define x2 (+ x0 (* r (+ (*  1.91125 (cos ϕ)) (* 1.58848 (sin ϕ))))))
  (define y2 (+ y0 (* r (+ (* -1.91125 (sin ϕ)) (* 1.58848 (cos ϕ))))))

  (define R (+ r d))
  
  (define in-c0? (make-in-circle? (+ r d)  x0  y0))
  (define in-c1? (make-in-circle? r        x0  y0))
  (define in-c2? (make-in-circle? r*       x1 y1))
  (define in-c3? (make-in-circle? (- r* d) x1 y1))
  (define in-c4? (make-in-circle? r*       x2 y2))
  (define in-c5? (make-in-circle? (- r* d) x2 y2))
    
  (λ (x* y)
    (define dx (/ (- x* x0) (cos θ)))
    (define x (+ x0 dx))
    (define z (/ dx 2 R))
    (define Z (+ (* (sin θ) z) .5))
    (if (in-c0? x y)
        (if (in-c1? x y)
            (if (in-c2? x y)
                (if (in-c3? x y)
                    (if (in-c4? x y)
                        (if (in-c5? x y)
                            0
                            Z)
                        0)
                    Z)
                0)
            Z)
        0)))

 ;***************************************************************************************************
 ;* Create/combine/mix patterns                                                                     *
 ;***************************************************************************************************
 (define (combine-logo-fcts lst)
  (λ (x y)
    (or
     (for*/first ([f (in-list lst)]
                  [v (in-value (f x y))]
                  #:unless (equal? v transparent))
       v)
     white)))

 (struct pmv (x v a r q t ϕ ω α) #:transparent)
 (define (next-pmv PMV [s 1])
  (match-define (pmv x v A r q T ϕ ω Ω) PMV)
  (define a (make-rectangular (* (- (random) 0.5) A 2) (* (- (random) 0.5) A 2)))
  (define t (* (- (random) 0.5) T 2))
  (define α (* (- (random) 0.5) Ω 2))
  (pmv (+ x (* v s) (* 0.5 s s a))
       (+ v (* a s))
       A
       (+ r (* q s) (* 0.5 s s t))
       (+ q (* t s))
       T
       (+ ϕ (* ω s) (* 0.5 s s α))
       (+ ω (* α s))
       Ω))
 (define (pmv->logo-fct PMV)
  (plt-logo-maker (real-part (pmv-x PMV))
                  (imag-part (pmv-x PMV))
                  (pmv-r PMV)
                  (pmv-ϕ PMV)))

 (define (evolve-pmvs steps PMVs)
  (let loop ([PMVs PMVs]
             [i 0])
    (cond
      [(<= steps i) '()]
      [else
       (cons PMVs (loop (map next-pmv PMVs) (+ i 1)))])))

 (define (modulo x n)
  (cond
    [(and (<= 0 x) (< x n)) x]
    [else (- x (* n (floor (/ x n))))]))

 (define (xrϕs->pattern XRΦs width height)
  (define fcts
    (apply
     append
     (for/list ([XRΦ (in-list XRΦs)])
       (map (λ (XRΦ)
              (apply plt-logo-maker
                     (real-part (car XRΦ))
                     (imag-part (car XRΦ))
                     (cdr XRΦ)))
            (hex XRΦ width height)))))
  (pattern (combine-logo-fcts fcts) width height))

 (define (hex XRΦ width height)
  (define X (list-ref XRΦ 0))
  (define x (make-rectangular (modulo (real-part X) width)
                              (modulo (imag-part X) height)))
  (define r (list-ref XRΦ 1))
  (define ϕ (list-ref XRΦ 2))
  (list (list (+ x (make-rectangular (- width) (- height))) r ϕ)
        (list (+ x (make-rectangular 0         (- height))) r ϕ)
        (list (+ x (make-rectangular (+ width) (- height))) r ϕ)

        (list (+ x (make-rectangular (- width) 0         )) r ϕ)
        (list (+ x (make-rectangular 0         0         )) r ϕ)
        (list (+ x (make-rectangular (+ width) 0         )) r ϕ)
             
        (list (+ x (make-rectangular (- width) (+ height))) r ϕ)
        (list (+ x (make-rectangular 0         (+ height))) r ϕ)
        (list (+ x (make-rectangular (+ width) (+ height))) r ϕ)
        ))

 (define (rotate-xrϕ steps XRΦs width height)
  (define free
    (filter (λ (XRΦ)
              (for/and ([o (in-list (apply append
                                           (map (λ (X) (hex X width height))
                                                (remove XRΦ XRΦs))))])
                (< (+ (cadr o) (cadr XRΦ))
                   (magnitude (- (car o) (car XRΦ))))))
            XRΦs))
  (displayln (format "->free ~a out of ~a" (length free) (length XRΦs)))
  (define temp
    (let loop ([s XRΦs]
               [f (shuffle free)])
      (cond
        [(empty? s) s]
        [(member (car s) free)
         (cons (car f) (loop (cdr s) (cdr f)))]
        [else (cons (car s) (loop (cdr s) f))])))
  (define end
    (for/list ([l (in-list temp)])
      (cons (+ (car l)
               (make-rectangular (* (- (random 21) 10) width)
                                 (* (- (random 21) 10) height)))
            (cdr l))))
  (define AXRΦs
    (for/list ([s (in-list XRΦs)]
               [e (in-list end)])
      (match-define (list xs rs ϕs) s)
      (match-define (list xe re ϕe) e)
      (cons s
            (for/list ([i (in-range 1 steps)])
              (define d (/ i steps))
              (list (+ xs (* d (- xe xs)))
                    (+ rs (* d (- re rs)))
                    (+ ϕs (* d (- ϕe ϕs))))))))
  (let loop ([AXRΦs AXRΦs])
    (cond
      [(or (empty? AXRΦs)
           (empty? (car AXRΦs)))
       '()]
      [(cons (map car AXRΦs)
             (loop (map cdr AXRΦs)))])))

 (define (random-xrϕ [x 200] [y 200] [r 20] [ϕ (* 2 (angle -1))])
  (list (make-rectangular (* x (random)) (* y (random)))
        (* r (random))
        (* ϕ (random))))

 ;***************************************************************************************************
 ;* Test                                                                                            *
 ;***************************************************************************************************
 (module+ test
  (depth->bitmap
   (let ([x 400][y 300])
     (depth (plt-3dlogo-maker x y (* 0.75 (min x y)) 0 0)
            (* x 2) (* y 2))))
  (pattern->bitmap (let ([r 200])(pattern (plt-logo-maker r r r 0) (* 2 r) (* 2 r))))
  (pattern->bitmap (let ([r 200])
                     (pattern (plt-logo-maker r r r (/ (angle -1) 2)) (* 2 r) (* 2 r)))))

 ;***************************************************************************************************
 ;* The image                                                                                       *
 ;***************************************************************************************************
 (define seed (random 2147483648))
 (displayln (format "seed: ~a" seed))
 (random-seed seed)

 (begin
  (define depth-list
    (for/list ([i (in-range 100)])
      (let ([x 500][y 300])
        (depth (plt-3dlogo-maker x y (* 0.75 (min x y)) 0 (* 2 (angle -1) i 1/100))
               (* x 2) (* y 2)))))
  (display "depth-list created")
  (mkgif (map depth->bitmap depth-list)     "depth.gif"   #:exists 'replace)
  (displayln " and written"))

 #;(begin
  (define pattern-list
    (map (λ (pmvs)
           (xrϕs->pattern
            (map (λ (PMV) (list (pmv-x PMV) (pmv-r PMV) (pmv-ϕ PMV))) pmvs)
            200 200))
         (evolve-pmvs
          100
          (list (pmv 020+015i 0 1    20 0 .1    0 0 .3)
                (pmv 050+030i 0 1    20 0 .1    0 0 .3)
                (pmv 075+045i 0 1    20 0 .1    0 0 .3)
                (pmv 100+060i 0 1    20 0 .1    0 0 .3)
                (pmv 125+075i 0 1    20 0 .1    0 0 .3)
                (pmv 150+090i 0 1    20 0 .1    0 0 .3)
                (pmv 175+105i 0 1    20 0 .1    0 0 .3)
                (pmv 150+120i 0 1    20 0 .1    0 0 .3)
                (pmv 125+135i 0 1    20 0 .1    0 0 .3)
                (pmv 100+150i 0 1    20 0 .1    0 0 .3)
                (pmv 075+165i 0 1    20 0 .1    0 0 .3)
                (pmv 050+180i 0 1    20 0 .1    0 0 .3)
                (pmv 035+195i 0 1    20 0 .1    0 0 .3)
                ))))
  (display "pattern-list created")
  (mkgif (map pattern->bitmap pattern-list) "pattern.gif" #:exists 'replace)
  (displayln " and written"))

 (begin
  (define pattern-list
    (map (λ (XRΦs) (xrϕs->pattern XRΦs 200 200))
         (rotate-xrϕ
          100
          (build-list 20 (λ (i) (random-xrϕ 200 200 40)))
          200 200)))
  (display "pattern-list created")
  (mkgif (map pattern->bitmap pattern-list) "pattern.gif" #:speed 10 #:exists 'replace)
  (displayln " and written"))

 (begin
  (define auto-list
    (map (λ (d p) (autostereogram #:depth d #:pattern p #:max-depth 20))
         depth-list
         pattern-list))
  (display "autostereograph-list created")
  (mkgif (map flomap->bitmap auto-list)     "auto.gif"     #:exists 'replace)
  (displayln " and written"))
	#lang typed/racket/base

	(require images/flomap
	(only-in math/flonum flvector flvector-length make-flvector flvector-set! flhypot fl)
	(only-in racket/flonum in-flvector)
	racket/math
	typed/racket/class
	(only-in typed/racket/draw bitmap%))

	(provide (except-out (all-defined-out)
	fill-stereo-flvector!
	fill-look-info-flvector!))

	;***************************************************************************************************
	;* Data structs & helpers *
	;***************************************************************************************************
	;; Depth contains the depth information of the 3d object.
	;; the at argument is a function that takes an x and y position argument and
	;; should return a value between 0 (= black = no pop out)
	;; and 1 (= white = maximum pop out)
	(struct depth ([at : (-> Nonnegative-Integer Nonnegative-Integer Real)]
	[width : Positive-Integer]
	[height : Positive-Integer])
	#:transparent
	#:type-name Depth)

	;; pattern contains information for creating a repeatable tile
	;; the at argument is a function that takes an x and y position argument and
	;; shoud return a FlVector (size 1 to 4) containing the color information at
	;; that point. (the same length FlVector should be returned for all points)
	(struct pattern ([at : (-> Nonnegative-Integer Nonnegative-Integer FlVector)]
	[width : Positive-Integer]
	[height : Positive-Integer])
	#:transparent
	#:type-name pattern)

	;; Convert a flomap-image to a pattern
	(define (flomap->pattern [F : flomap])
	(pattern (λ ([x : Nonnegative-Integer][y : Nonnegative-Integer]) (flomap-ref* F x y))
	(cast (flomap-width F) Positive-Integer)
	(cast (flomap-height F) Positive-Integer)))

	;; convert a depth element to a bitmap
	(define (depth->bitmap [D : Depth])
	(flomap->bitmap
	(build-flomap 1 (depth-width D)(depth-height D)
	(λ (k [x : Nonnegative-Integer][y : Nonnegative-Integer])
	((depth-at D) x y)))))

	;; convert a pattern to a bitmap
	(define (pattern->bitmap [P : pattern])
	(define c (flvector-length ((pattern-at P) 0 0)))
	(flomap->bitmap
	(build-flomap* c (pattern-width P)(pattern-height P)
	(λ ([x : Nonnegative-Integer][y : Nonnegative-Integer])
	((pattern-at P) x y)))))

	;***************************************************************************************************
	;* Other helpers *
	;***************************************************************************************************
	;; Create a random pattern
	(define (make-random-pattern [width : Positive-Integer 100]
	[height : Positive-Integer width]
	#:components [c : Positive-Byte 3]) : pattern
	(unless (<= 1 c 4) (raise-argument-error 'make-random-pattern "(U 1 2 3 4)" c))
	(define P (build-flomap* c width height (λ any (build-vector c (λ (i)(random))))))
	(pattern (λ ([x : Nonnegative-Integer][y : Nonnegative-Integer])
	(flomap-ref* P x y))
	width height))

	;; Create a checkers-board pattern
	(define (checkers-pattern [size : Positive-Integer][number : Positive-Integer])
	(define M (* 2 size))
	(define N (* M number))
	(pattern (λ ([x : Nonnegative-Integer][y : Nonnegative-Integer])
	(flvector
	(if (< (modulo x M) size)
	(if (< (modulo y M) size) 1. 0.)
	(if (< (modulo y M) size) 0. 1.))))
	N N))

	;; Check if a point is in a circle
	(define (make-in-circle? [R : Real][cx : Real 0][cy : Real 0])
	(define R² (expt R 2))
	(λ ([x : Real][y : Real])
	(< (+ (expt (- x cx) 2)
	(expt (- y cy) 2))
	R²)))

	;; Check the distance from a point to a line
	(define (make-from-line [x1 : Real][y1 : Real][x2 : Real][y2 : Real])
	(λ ([x : Real][y : Real])
	(/ (+ (* (- y1 y2) (- x x1))(* (- x2 x1) (- y y1)) 0)
	(flhypot (fl (- y2 y1)) (fl (- x2 x1))))))

	;***************************************************************************************************
	;* Autostereograms *
	;***************************************************************************************************
	;; Create an autostereogram (flomap)
	;; #:depth: (mandatory) the 3d image to embed in the autostereogram
	;; #:pattern: the tile to use for the background (default to random-pattern)
	;; #;max-depth: specifies how far the 3d image can pop out. If this value is to big, the
	;; autostereographic effect will not work. (max = pattern-width)
	;; Best is to keep it below 25% of the pattern width. (= default)
	;; #:looking-info?: add 2 dots above the image to show the distance for the pattern (default is #f)
	;; #:type: create the autostereogram for cross-eyed, or parallel looking (default is parallel)

	(define (autostereogram #:depth [D : Depth]
	#:pattern [P : pattern (make-random-pattern (ceiling (* (depth-width D) 1/5)))]
	#:max-depth [max-depth : Positive-Integer (ceiling (* (pattern-width P) 1/8))]
	#:looking-info? [li? : Boolean #t]
	#:type [type : (U 'cross 'parallel) 'parallel]) : flomap
	(when (< (pattern-width P) max-depth)
	(raise-argument-error 'autostereogram
	(format "max-depth smaller than pattern width (~a)" (pattern-width P))
	max-depth))
	(define li-height 20)
	(define c (flvector-length ((pattern-at P) 0 0)))
	(define width (depth-width D))
	(define height (depth-height D))
	(define total-height (+ height (if li? li-height 0)))
	(define fl (make-flvector (* c width total-height)))

	(when li?
	(fill-look-info-flvector! fl width height
	(pattern-width P) li-height total-height
	c (eq? type 'cross)))

	(fill-stereo-flvector! fl D P width height c max-depth)

	(flomap fl c width total-height))

	(: fill-stereo-flvector!
	(-> FlVector Depth pattern Positive-Integer Positive-Integer Index Positive-Integer
	Void))
	(define (fill-stereo-flvector! fl D P width height c max-depth)
	(for* ([yi : Nonnegative-Integer (in-range height)]
	[xi : Nonnegative-Integer (in-range width)])
	(define Ii (coords->index c width 0 xi yi))
	(define xd (- xi (- (pattern-width P)
	(exact-round (* ((depth-at D) xi yi) max-depth)))))

	(for ([vj (if (< xd (pattern-width P))
	(in-flvector ((pattern-at P) (modulo xd (pattern-width P))
	(modulo yi (pattern-height P))))
	(let ([index (coords->index c width 0 xd yi)])
	(in-flvector fl index (+ index c))))]
	[j (in-naturals)])
	(flvector-set! fl (+ Ii j) vj)
	'done-aRGB)
	'done-pixel))

	(: fill-look-info-flvector!
	(-> FlVector Positive-Integer Positive-Integer Positive-Integer Positive-Integer Positive-Integer Index Boolean
	Void))
	(define (fill-look-info-flvector! fl width height p-width li-height total-height c cross?)
	(define R (* li-height .25))
	(define h/2 (+ height (/ li-height 2)))
	(define in-c1? (make-in-circle? R (/ (- width p-width) 2) h/2))
	(define in-c2? (make-in-circle? R (/ (+ width p-width) 2) h/2))
	(define Cx (- width li-height))
	(define ym (+ height 2))
	(define l1 (make-from-line (- Cx (* 1.5 R)) ym ((if cross? + -) Cx (* 1.5 R)) total-height))
	(define l2 (make-from-line (+ Cx (* 1.5 R)) ym ((if cross? - +) Cx (* 1.5 R)) total-height))

	(for* ([xi : Nonnegative-Integer (in-range width)]
	[yi : Nonnegative-Integer (in-range height total-height)])
	(define Ii (coords->index c width 0 xi yi))
	(for ([j (in-range c)])
	(flvector-set! fl (+ Ii j)
	(if (or (in-c1? xi yi)
	(in-c2? xi yi)
	(and (< (+ height 2) yi)
	(or (<= (abs (l1 xi yi)) 1)
	(<= (abs (l2 xi yi)) 1))))
	0.0
	1.0)))))

	;***************************************************************************************************
	;* Tests and image *
	;***************************************************************************************************

	(module+ test
	;****depth maps*****
	(define circle
	(let ([in-circle1? (make-in-circle? 80 200 200)]
	[in-circle2? (make-in-circle? 90 200 200)])
	(depth (λ (x y)
	(if (in-circle2? x y)
	(if (in-circle1? x y) 1 .5)
	0))
	400 400))))

	(module+ test
	(depth->bitmap circle)
	(pattern->bitmap (make-random-pattern #:components 1))
	(pattern->bitmap (make-random-pattern #:components 2))
	(pattern->bitmap (make-random-pattern #:components 3))
	(pattern->bitmap (make-random-pattern #:components 4))
	(flomap->bitmap (autostereogram #:depth circle
	#:pattern (checkers-pattern 25 2)
	#:max-depth 5))
	(flomap->bitmap (autostereogram #:depth circle
	#:max-depth 20))
	(flomap->bitmap (autostereogram #:depth (depth (λ (x y)
	(define dx (- x 200))
	(define dy (- y 200))
	(define r (sqrt (+ (sqr dx) (sqr dy))))
	(if (< r 100) (/ (- 100 r) 100) 0))
	400 400)
	#:max-depth 5))
	(flomap->bitmap (autostereogram #:depth (depth (λ (x y)
	(define dx (- x 200))
	(define dy (- y 200))
	(define r (sqrt (+ (sqr dx) (sqr dy))))
	(if (< r 100) (/ (- 100 r) 100) 0))
	400 400)
	#:max-depth 10))
	(flomap->bitmap (autostereogram #:depth (depth (λ (x y)
	(define dx (- x 200))
	(define dy (- y 200))
	(define r (sqrt (+ (sqr dx) (sqr dy))))
	(if (< r 100) (/ (- 100 r) 100) 0))
	400 400)
	#:max-depth 15))
	(flomap->bitmap (autostereogram #:depth (depth (λ (x y)
	(define dx (- x 200))
	(define dy (- y 200))
	(define r (sqrt (+ (sqr dx) (sqr dy))))
	(if (< r 100) (/ (- 100 r) 100) 0))
	400 400)
	#:max-depth 20))
	(flomap->bitmap (autostereogram #:depth (depth (λ (x y)
	(define dx (- x 200))
	(define dy (- y 200))
	(define r (sqrt (+ (sqr dx) (sqr dy))))
	(if (< r 100) (/ (- 100 r) 100) 0))
	400 400)
	#:pattern (checkers-pattern 20 2)
	#:max-depth 20)))
	#lang racket/base

	(require racket/match
	racket/list
	mrlib/gif
	images/flomap
	(only-in math/flonum flvector))

	(require "autostereo.rkt")

	(define (mkgif lst name
	#:speed [speed 10]
	#:exists [exists 'error])
	(when (and (file-exists? name) (eq? exists 'replace))
	(delete-file name))
	(write-animated-gif lst speed name))

	(define transparent (flvector 0. 1. 1. 1.))
	(define white (flvector 1. 1. 1. 1.))

	;***************************************************************************************************
	;* Logos *
	;***************************************************************************************************
	(define (plt-logo-maker x y r [ϕ 0] [d (* 0.25 r)])
	(define r* (* r 2.77425))
	(define x1 (+ x (* r (+ (* -1.92114 (cos ϕ)) (* 1.39882 (sin ϕ))))))
	(define y1 (+ y (* r (+ (* 1.92114 (sin ϕ)) (* 1.39882 (cos ϕ))))))
	(define x2 (+ x (* r (+ (* 1.91125 (cos ϕ)) (* 1.58848 (sin ϕ))))))
	(define y2 (+ y (* r (+ (* -1.91125 (sin ϕ)) (* 1.58848 (cos ϕ))))))
	(define in-c1? (make-in-circle? r x y))
	(define in-c2? (make-in-circle? r* x1 y1))
	(define in-c3? (make-in-circle? (- r* d) x1 y1))
	(define in-c4? (make-in-circle? r* x2 y2))
	(define in-c5? (make-in-circle? (- r* d) x2 y2))
	(define white (flvector 1. 1. 1. 1.))
	(define red (flvector 1. .623529 .11375 .12549))
	(define blue (flvector 1. .243137 .356863 .662745))
	(λ (x y)
	(if (in-c1? x y)
	(if (in-c2? x y)
	(if (in-c3? x y)
	(if (in-c4? x y)
	(if (in-c5? x y)
	red
	white)
	red)
	white)
	blue)
	transparent)))

	(define (plt-3dlogo-maker x0 y0 r [ϕ 0] [θ 0] [d (* 0.25 r)])
	(define r* (* r 2.77425))
	(define x1 (+ x0 (* r (+ (* -1.92114 (cos ϕ)) (* 1.39882 (sin ϕ))))))
	(define y1 (+ y0 (* r (+ (* 1.92114 (sin ϕ)) (* 1.39882 (cos ϕ))))))

	(define x2 (+ x0 (* r (+ (* 1.91125 (cos ϕ)) (* 1.58848 (sin ϕ))))))
	(define y2 (+ y0 (* r (+ (* -1.91125 (sin ϕ)) (* 1.58848 (cos ϕ))))))

	(define R (+ r d))

	(define in-c0? (make-in-circle? (+ r d) x0 y0))
	(define in-c1? (make-in-circle? r x0 y0))
	(define in-c2? (make-in-circle? r* x1 y1))
	(define in-c3? (make-in-circle? (- r* d) x1 y1))
	(define in-c4? (make-in-circle? r* x2 y2))
	(define in-c5? (make-in-circle? (- r* d) x2 y2))

	(λ (x* y)
	(define dx (/ (- x* x0) (cos θ)))
	(define x (+ x0 dx))
	(define z (/ dx 2 R))
	(define Z (+ (* (sin θ) z) .5))
	(if (in-c0? x y)
	(if (in-c1? x y)
	(if (in-c2? x y)
	(if (in-c3? x y)
	(if (in-c4? x y)
	(if (in-c5? x y)
	0
	Z)
	0)
	Z)
	0)
	Z)
	0)))

	;***************************************************************************************************
	;* Create/combine/mix patterns *
	;***************************************************************************************************
	(define (combine-logo-fcts lst)
	(λ (x y)
	(or
	(for*/first ([f (in-list lst)]
	[v (in-value (f x y))]
	#:unless (equal? v transparent))
	v)
	white)))

	(struct pmv (x v a r q t ϕ ω α) #:transparent)
	(define (next-pmv PMV [s 1])
	(match-define (pmv x v A r q T ϕ ω Ω) PMV)
	(define a (make-rectangular (* (- (random) 0.5) A 2) (* (- (random) 0.5) A 2)))
	(define t (* (- (random) 0.5) T 2))
	(define α (* (- (random) 0.5) Ω 2))
	(pmv (+ x (* v s) (* 0.5 s s a))
	(+ v (* a s))
	A
	(+ r (* q s) (* 0.5 s s t))
	(+ q (* t s))
	T
	(+ ϕ (* ω s) (* 0.5 s s α))
	(+ ω (* α s))
	Ω))
	(define (pmv->logo-fct PMV)
	(plt-logo-maker (real-part (pmv-x PMV))
	(imag-part (pmv-x PMV))
	(pmv-r PMV)
	(pmv-ϕ PMV)))

	(define (evolve-pmvs steps PMVs)
	(let loop ([PMVs PMVs]
	[i 0])
	(cond
	[(<= steps i) '()]
	[else
	(cons PMVs (loop (map next-pmv PMVs) (+ i 1)))])))

	(define (modulo x n)
	(cond
	[(and (<= 0 x) (< x n)) x]
	[else (- x (* n (floor (/ x n))))]))

	(define (xrϕs->pattern XRΦs width height)
	(define fcts
	(apply
	append
	(for/list ([XRΦ (in-list XRΦs)])
	(map (λ (XRΦ)
	(apply plt-logo-maker
	(real-part (car XRΦ))
	(imag-part (car XRΦ))
	(cdr XRΦ)))
	(hex XRΦ width height)))))
	(pattern (combine-logo-fcts fcts) width height))

	(define (hex XRΦ width height)
	(define X (list-ref XRΦ 0))
	(define x (make-rectangular (modulo (real-part X) width)
	(modulo (imag-part X) height)))
	(define r (list-ref XRΦ 1))
	(define ϕ (list-ref XRΦ 2))
	(list (list (+ x (make-rectangular (- width) (- height))) r ϕ)
	(list (+ x (make-rectangular 0 (- height))) r ϕ)
	(list (+ x (make-rectangular (+ width) (- height))) r ϕ)

	(list (+ x (make-rectangular (- width) 0 )) r ϕ)
	(list (+ x (make-rectangular 0 0 )) r ϕ)
	(list (+ x (make-rectangular (+ width) 0 )) r ϕ)

	(list (+ x (make-rectangular (- width) (+ height))) r ϕ)
	(list (+ x (make-rectangular 0 (+ height))) r ϕ)
	(list (+ x (make-rectangular (+ width) (+ height))) r ϕ)
	))

	(define (rotate-xrϕ steps XRΦs width height)
	(define free
	(filter (λ (XRΦ)
	(for/and ([o (in-list (apply append
	(map (λ (X) (hex X width height))
	(remove XRΦ XRΦs))))])
	(< (+ (cadr o) (cadr XRΦ))
	(magnitude (- (car o) (car XRΦ))))))
	XRΦs))
	(displayln (format "->free ~a out of ~a" (length free) (length XRΦs)))
	(define temp
	(let loop ([s XRΦs]
	[f (shuffle free)])
	(cond
	[(empty? s) s]
	[(member (car s) free)
	(cons (car f) (loop (cdr s) (cdr f)))]
	[else (cons (car s) (loop (cdr s) f))])))
	(define end
	(for/list ([l (in-list temp)])
	(cons (+ (car l)
	(make-rectangular (* (- (random 21) 10) width)
	(* (- (random 21) 10) height)))
	(cdr l))))
	(define AXRΦs
	(for/list ([s (in-list XRΦs)]
	[e (in-list end)])
	(match-define (list xs rs ϕs) s)
	(match-define (list xe re ϕe) e)
	(cons s
	(for/list ([i (in-range 1 steps)])
	(define d (/ i steps))
	(list (+ xs (* d (- xe xs)))
	(+ rs (* d (- re rs)))
	(+ ϕs (* d (- ϕe ϕs))))))))
	(let loop ([AXRΦs AXRΦs])
	(cond
	[(or (empty? AXRΦs)
	(empty? (car AXRΦs)))
	'()]
	[(cons (map car AXRΦs)
	(loop (map cdr AXRΦs)))])))

	(define (random-xrϕ [x 200] [y 200] [r 20] [ϕ (* 2 (angle -1))])
	(list (make-rectangular (* x (random)) (* y (random)))
	(* r (random))
	(* ϕ (random))))

	;***************************************************************************************************
	;* Test *
	;***************************************************************************************************
	(module+ test
	(depth->bitmap
	(let ([x 400][y 300])
	(depth (plt-3dlogo-maker x y (* 0.75 (min x y)) 0 0)
	(* x 2) (* y 2))))
	(pattern->bitmap (let ([r 200])(pattern (plt-logo-maker r r r 0) (* 2 r) (* 2 r))))
	(pattern->bitmap (let ([r 200])
	(pattern (plt-logo-maker r r r (/ (angle -1) 2)) (* 2 r) (* 2 r)))))

	;***************************************************************************************************
	;* The image *
	;***************************************************************************************************
	(define seed (random 2147483648))
	(displayln (format "seed: ~a" seed))
	(random-seed seed)

	(begin
	(define depth-list
	(for/list ([i (in-range 100)])
	(let ([x 500][y 300])
	(depth (plt-3dlogo-maker x y (* 0.75 (min x y)) 0 (* 2 (angle -1) i 1/100))
	(* x 2) (* y 2)))))
	(display "depth-list created")
	(mkgif (map depth->bitmap depth-list) "depth.gif" #:exists 'replace)
	(displayln " and written"))

	#;(begin
	(define pattern-list
	(map (λ (pmvs)
	(xrϕs->pattern
	(map (λ (PMV) (list (pmv-x PMV) (pmv-r PMV) (pmv-ϕ PMV))) pmvs)
	200 200))
	(evolve-pmvs
	100
	(list (pmv 020+015i 0 1 20 0 .1 0 0 .3)
	(pmv 050+030i 0 1 20 0 .1 0 0 .3)
	(pmv 075+045i 0 1 20 0 .1 0 0 .3)
	(pmv 100+060i 0 1 20 0 .1 0 0 .3)
	(pmv 125+075i 0 1 20 0 .1 0 0 .3)
	(pmv 150+090i 0 1 20 0 .1 0 0 .3)
	(pmv 175+105i 0 1 20 0 .1 0 0 .3)
	(pmv 150+120i 0 1 20 0 .1 0 0 .3)
	(pmv 125+135i 0 1 20 0 .1 0 0 .3)
	(pmv 100+150i 0 1 20 0 .1 0 0 .3)
	(pmv 075+165i 0 1 20 0 .1 0 0 .3)
	(pmv 050+180i 0 1 20 0 .1 0 0 .3)
	(pmv 035+195i 0 1 20 0 .1 0 0 .3)
	))))
	(display "pattern-list created")
	(mkgif (map pattern->bitmap pattern-list) "pattern.gif" #:exists 'replace)
	(displayln " and written"))

	(begin
	(define pattern-list
	(map (λ (XRΦs) (xrϕs->pattern XRΦs 200 200))
	(rotate-xrϕ
	100
	(build-list 20 (λ (i) (random-xrϕ 200 200 40)))
	200 200)))
	(display "pattern-list created")
	(mkgif (map pattern->bitmap pattern-list) "pattern.gif" #:speed 10 #:exists 'replace)
	(displayln " and written"))

	(begin
	(define auto-list
	(map (λ (d p) (autostereogram #:depth d #:pattern p #:max-depth 20))
	depth-list
	pattern-list))
	(display "autostereograph-list created")
	(mkgif (map flomap->bitmap auto-list) "auto.gif" #:exists 'replace)
	(displayln " and written"))