<commit_before>#|

The test suite for this code is in
plt/collects/tests/mzscheme/image-test.ss

|#

#lang scheme/base

(require mred
         mzlib/class
         (lib "cache-image-snip.ss" "mrlib")
         mzlib/math
         (lib "posn.ss" "lang")
         (lib "imageeq.ss" "lang" "private")
         "error.ss")

(provide image-width
         image-height
         overlay
         overlay/xy
         
         pinhole-x
         pinhole-y
         move-pinhole
         put-pinhole
         
         rectangle
         circle
         ellipse
         triangle
         line
         star
         add-line
         text
         regular-polygon
         
         shrink
         shrink-tl
         shrink-tr
         shrink-bl
         shrink-br
         
         image-inside?
         find-image
         
         image->color-list
         color-list->image
         
         image->alpha-color-list
         alpha-color-list->image
         
         image-color?
         make-color
         color-red
         color-green
         color-blue
         color?
         make-alpha-color
         alpha-color-alpha
         alpha-color-red
         alpha-color-green
         alpha-color-blue
         alpha-color?)

;; ----------------------------------------

(define (color-list? l)
  (and (list? l) (andmap image-color? l)))
(define (alpha-color-list? l)
  (and (list? l) (andmap alpha-color? l)))

(define-struct color (red green blue) #:inspector (make-inspector))
(define-struct alpha-color (alpha red green blue) #:inspector (make-inspector))

;; ----------------------------------------

(define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v))

(define (check-coordinate name val arg-posn) (check name finite-real? val "finite real number" arg-posn))
(define (check-integer-coordinate name val arg-posn) (check name nii? val "integer" arg-posn))
(define (check-size name val arg-posn) (check name pos-number? val "positive number" arg-posn))
(define (check-posi-size name val arg-posn) (check name pos-integer? val "positive integer" arg-posn))
(define (check-size/0 name val arg-posn) (check name nn-number? val "non-negative number" arg-posn))
(define (check-image name val arg-posn) (check name image? val "image" arg-posn))
(define (check-image-color name val arg-posn) 
  (let ([simple-check (λ (x) (or (string? x) (symbol? x) (color? x)))])
    (check name simple-check val "image-color" arg-posn)
    (unless (image-color? val)
      (error name "~e is not a valid color name" val))))
(define (check-mode name val arg-posn) (check name mode? val mode-str arg-posn))

(define (pos-number? i) (and (number? i) (positive? i)))
(define (pos-integer? i) (and (number? i) (positive? i) (integer? i)))
(define (nn-number? i) (and (number? i) (or (zero? i) (positive? i))))
(define (nii? x) (and (integer? x) (not (= x +inf.0)) (not (= x -inf.0))))
(define (finite-real? x) (and (real? x) (not (= x +inf.0)) (not (= x -inf.0))))

(define (check-sizes who w h)
  (unless (and (< 0 w 10000) (< 0 h 10000))
    (error (format "cannot make ~a x ~a image" w h))))

(define (mode? x)
  (member x '(solid "solid" outline "outline")))

(define mode-str "'solid \"solid\" 'outline or \"outline\"")

(define (mode->brush-symbol m)
  (cond
    [(member m '(solid "solid"))
     'solid]
    [(member m '(outline "outline"))
     'transparent]))

(define (mode->pen-symbol m)
  (cond
    [(member m '(solid "solid")) 'transparent]
    [(member m '(outline "outline")) 'solid]))

(define (make-color% c)
  (cond
    [(string? c) (send the-color-database find-color c)]
    [(symbol? c) (send the-color-database find-color (symbol->string c))]
    [(color? c) (make-object color%
                  (color-red c)
                  (color-green c)
                  (color-blue c))]
    [else #f]))

(define (image-color? c) 
  (cond
    [(color? c) #t]
    [(string? c) (and (send the-color-database find-color c) #t)]
    [(symbol? c) (and (send the-color-database find-color (symbol->string c)) #t)]
    [else #f]))

(define (image-width a)
  (check-image 'image-width a "first")
  (let-values ([(w h) (snip-size a)])
    (inexact->exact (ceiling w))))

(define (image-height a)
  (check-image 'image-height a "first")
  (let-values ([(w h) (snip-size a)])
    (inexact->exact (ceiling h))))

(define (pinhole-x a)
  (check-image 'pinhole-x a "first")
  (let-values ([(x y) (send (coerce-to-cache-image-snip a) get-pinhole)])
    x))

(define (pinhole-y a)
  (check-image 'pinhole-y a "first")
  (let-values ([(x y) (send (coerce-to-cache-image-snip a) get-pinhole)])
    y))

(define (move-pinhole raw-i dx dy)
  (check-image 'move-pinhole raw-i "first")
  (check-coordinate 'move-pinhole dx "second")
  (check-coordinate 'move-pinhole dy "third")
  (let ([i (coerce-to-cache-image-snip raw-i)])
    (let-values ([(px py) (send i get-pinhole)]
                 [(w h) (send i get-size)])
      (new cache-image-snip%
           (dc-proc (send i get-dc-proc))
           (argb-proc (send i get-argb-proc))
           (width w)
           (height h)
           (argb (send i get-argb/no-compute))
           (px (+ px dx))
           (py (+ py dy))))))

(define (put-pinhole raw-i px py)
  (check-image 'put-pinhole raw-i "first")
  (check-coordinate 'put-pinhole px "second")
  (check-coordinate 'put-pinhole py "third")
  (let ([i (coerce-to-cache-image-snip raw-i)])
    (let-values ([(w h) (send i get-size)])
      (new cache-image-snip%
           (dc-proc (send i get-dc-proc))
           (argb-proc (send i get-argb-proc))
           (width w)
           (height h)
           (argb (send i get-argb/no-compute))
           (px (floor px))
           (py (floor py))))))

(define (overlay a b . cs)
  (check-image 'overlay a "first")
  (check-image 'overlay b "second")
  (let loop ([cs cs]
             [i 3])
    (unless (null? cs)
      (check-image 'overlay (car cs) (number->ord i))))
  (let ([all-imgs (reverse (list* a b cs))])
    (let loop ([imgs (cdr all-imgs)]
               [acc (car all-imgs)])
      (cond
        [(null? imgs) acc]
        [else (loop (cdr imgs)
                    (real-overlay/xy 'overlay (car imgs) 0 0 acc))]))))

(define (overlay/xy a dx dy b)
  (check-image 'overlay/xy a "first")
  (check-coordinate 'overlay/xy dx "second")
  (check-coordinate 'overlay/xy dy "third")
  (check-image 'overlay/xy b "fourth")
  (real-overlay/xy 'overlay/xy 
                   a
                   (floor (if (exact? dx) dx (inexact->exact dx)))
                   (floor (if (exact? dy) dy (inexact->exact dy)))
                   b))

(define (real-overlay/xy name raw-a raw-delta-x raw-delta-y raw-b)
  (let ([a (coerce-to-cache-image-snip raw-a)]
        [b (coerce-to-cache-image-snip raw-b)])
    (let-values ([(a-w a-h) (snip-size a)]
                 [(b-w b-h) (snip-size b)]
                 [(a-px a-py) (send a get-pinhole)]
                 [(b-px b-py) (send b get-pinhole)])
      (let* ([delta-x (+ raw-delta-x a-px (- b-px))]
             [delta-y (+ raw-delta-y a-py (- b-py))]
             [left (min 0 delta-x)]
             [top (min 0 delta-y)]
             [right (max (+ delta-x b-w) a-w)]
             [bottom (max (+ delta-y b-h) a-h)]
             [new-w (inexact->exact (ceiling (- right left)))]
             [new-h (inexact->exact (ceiling (- bottom top)))]
             [a-dx (inexact->exact (round (- left)))]
             [a-dy (inexact->exact (round (- top)))]
             [b-dx (inexact->exact (round (- delta-x left)))]
             [b-dy (inexact->exact (round (- delta-y top)))]
             [new-px (- a-px left)]
             [new-py (- a-py top)]
             [combine (lambda (a-f b-f)
                        (lambda (dc dx dy)
                          (a-f dc (+ dx a-dx) (+ dy a-dy))
                          (b-f dc (+ dx b-dx) (+ dy b-dy))))])
        (check-sizes name new-w new-h)
        (new cache-image-snip%
             [dc-proc (combine (send a get-dc-proc)
                               (send b get-dc-proc))]
             [argb-proc (combine (send a get-argb-proc)
                                 (send b get-argb-proc))]
             [width new-w]
             [height new-h]
             [px new-px]
             [py new-py])))))
;; ------------------------------------------------------------

(define (shrink raw-img in-left in-up in-right in-down)
  (check-image 'shrink raw-img "first")
  (check-size/0 'shrink in-left "second")
  (check-size/0 'shrink in-up "third")
  (check-size/0 'shrink in-right "fourth")
  (check-size/0 'shrink in-down "fifth")
  (let ([left (inexact->exact (floor in-left))]
        [up (inexact->exact (floor in-up))]
        [right (inexact->exact (floor in-right))]
        [down (inexact->exact (floor in-down))]
        [img (coerce-to-cache-image-snip raw-img)])
    (let-values ([(i-px i-py) (send img get-pinhole)]
                 [(i-width i-height) (send img get-size)])
      (let* ([dc-proc (send img get-dc-proc)]
             [argb-proc (send img get-argb-proc)]
             [delta-w (- i-px left)]
             [delta-h (- i-py up)]
             [width (+ left right 1)]
             [height (+ up down 1)])
        (new cache-image-snip%
             [px left]
             [py up]
             [dc-proc (lambda (dc dx dy)
                        (let ([clip (send dc get-clipping-region)]
                              [rgn (make-object region% dc)])
                          (send rgn set-rectangle dx dy width height)
                          (when clip
                            (send rgn intersect clip))
                          (send dc set-clipping-region rgn)
                          (dc-proc dc (- dx delta-w) (- dy delta-h))
                          (send dc set-clipping-region clip)))]
             [argb-proc (lambda (argb dx dy) (argb-proc argb (- dx delta-w) (- dy delta-h)))]
             [width width]
             [height height])))))

(define (shrink-tl raw-img in-x in-y)
  (check-image 'shrink-tl raw-img "first")
  (check-size 'shrink-tl in-x "second")
  (check-size 'shrink-tl in-y "third")
  (let ([x (inexact->exact (floor in-x))]
        [y (inexact->exact (floor in-y))])
    (put-pinhole (shrink (put-pinhole raw-img 0 0) 0 0 (- x 1) (- y 1)) (/ x 2) (/ y 2))))

(define (shrink-tr raw-img in-x in-y)
  (check-image 'shrink-tr raw-img "first")
  (check-size 'shrink-tr in-x "second")
  (check-size 'shrink-tr in-y "third")
  (let ([x (inexact->exact (floor in-x))]
        [y (inexact->exact (floor in-y))])
    (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) 0) (- x 1) 0 0 (- y 1))
                 (/ x 2)
                 (/ y 2))))

(define (shrink-bl raw-img in-x in-y)
  (check-image 'shrink-bl raw-img "first")
  (check-size 'shrink-bl in-x "second")
  (check-size 'shrink-bl in-y "third")
  (let ([x (inexact->exact (floor in-x))]
        [y (inexact->exact (floor in-y))])
    (put-pinhole (shrink (put-pinhole raw-img 0 (- (image-height raw-img) 1)) 0 (- y 1) (- x 1) 0) 
                 (/ x 2)
                 (/ y 2))))

(define (shrink-br raw-img in-x in-y)
  (check-image 'shrink-br raw-img "first")
  (check-size 'shrink-br in-x "second")
  (check-size 'shrink-br in-y "third")
  (let ([x (inexact->exact (floor in-x))]
        [y (inexact->exact (floor in-y))])
    (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) (- (image-height raw-img) 1))
                         (- x 1)
                         (- y 1)
                         0
                         0)
                 (/ x 2)
                 (/ y 2))))


;; ------------------------------------------------------------

(define (line in-x in-y color)
  (check-coordinate 'line in-x "first")
  (check-coordinate 'line in-y "second")
  (check-image-color 'line color "third")
  (let* ([x (floor (inexact->exact in-x))]
         [y (floor (inexact->exact in-y))]
         [w (+ (abs x) 1)]
         [h (+ (abs y) 1)]
         [px (abs (min x 0))]
         [py (abs (min y 0))])
    (check-sizes 'line w h)
    (let* ([do-draw
            (λ (dc dx dy)
              (send dc draw-line (+ px dx) (+ py dy) (+ dx px x) (+ dy py y)))]
           [draw-proc (make-color-wrapper color 'transparent 'solid do-draw)]
           [mask-proc (make-color-wrapper 'black 'transparent 'solid do-draw)])
      (make-simple-cache-image-snip w h px py draw-proc mask-proc))))

;; test what happens when the line moves out of the box.
(define (add-line raw-i pre-x1 pre-y1 pre-x2 pre-y2 color-in)
  (check-image 'add-line raw-i "first")
  (check-coordinate 'add-line pre-x1 "second")
  (check-coordinate 'add-line pre-y1 "third")
  (check-coordinate 'add-line pre-x2 "fourth")
  (check-coordinate 'add-line pre-y2 "fifth")
  (check-image-color 'add-line color-in "sixth")
  (let ([i (coerce-to-cache-image-snip raw-i)])
    (let-values ([(px py) (send i get-pinhole)]
                 [(iw ih) (send i get-size)]
                 [(x1 y1 x2 y2)
                  (if (<= pre-x1 pre-x2)
                      (values pre-x1 pre-y1 pre-x2 pre-y2)
                      (values pre-x2 pre-y2 pre-x1 pre-y1))])
      (let* ([line-w (abs (- x2 x1))]
             [line-h (abs (- y2 y1))]
             [build-snip
              (λ (do-draw py-offset)
                (let* ([draw-proc 
                        (make-color-wrapper color-in 'transparent 'solid do-draw)]
                       [mask-proc
                        (make-color-wrapper 'black 'transparent 'solid do-draw)]
                       [line
                        (make-simple-cache-image-snip (+ line-w 1) (+ line-h 1) px py draw-proc mask-proc)])
                  (real-overlay/xy 'add-line i (+ px x1) (+ py py-offset) line)))])
        (if (y1 . <= . y2)
            (build-snip (λ (dc dx dy)
                          (send dc draw-line 
                                dx
                                dy
                                (+ dx (- x2 x1))
                                (+ dy (- y2 y1))))
                        y1)
            (build-snip (λ (dc dx dy)
                          (send dc draw-line 
                                dx
                                (+ dy line-h)
                                (+ dx line-w)
                                dy))
                        y2))))))

(define (text str size color-in)
  (check 'text (lambda (x) (and (string? x) (not (equal? "" x)))) str "non-empty string" "first")
  (check 'text (lambda (x) (and (integer? x) (<= 1 x 255))) size "integer between 1 and 255" "second")
  (check-image-color 'text color-in "third")
  (let ([color (make-color% color-in)])
    (let-values ([(tw th) (get-text-size size str)])
      (let ([draw-proc
             (lambda (txt-color mode dc dx dy)
               (let ([old-mode (send dc get-text-mode)]
                     [old-fore (send dc get-text-foreground)]
                     [old-font (send dc get-font)])
                 (send dc set-text-mode mode)
                 (send dc set-text-foreground txt-color)
                 (send dc set-font (get-font size))
                 (send dc draw-text str dx dy)
                 (send dc set-text-mode old-mode)
                 (send dc set-text-foreground old-fore)
                 (send dc set-font old-font)))])
        (new cache-image-snip%
             [dc-proc (lambda (dc dx dy) (draw-proc color 'transparent dc dx dy))]
             [argb-proc 
              (lambda (argb dx dy)
                (let ([bm-color
                       (build-bitmap
                        (lambda (dc)
                          (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
                          (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))
                          (send dc draw-rectangle 0 0 tw th))
                        tw
                        th)]
                      [bm-mask
                       (build-bitmap
                        (lambda (dc)
                          (draw-proc 
                           (send the-color-database find-color "black")
                           'solid dc 0 0))
                        tw
                        th)])
                  (overlay-bitmap argb dx dy bm-color bm-mask)))]
             [width tw]
             [height th]
             [px 0]
             [py 0])))))

(define cached-bdc-for-text-size (make-thread-cell #f))
(define (get-text-size size string)
  (unless (thread-cell-ref cached-bdc-for-text-size)
    (let* ([bm (make-object bitmap% 1 1)]
           [dc (make-object bitmap-dc% bm)])
      (thread-cell-set! cached-bdc-for-text-size dc)))
  (let ([dc (thread-cell-ref cached-bdc-for-text-size)])
    (let-values ([(w h _1 _2) (send dc get-text-extent string (get-font size))])
      (values (inexact->exact (ceiling w)) 
              (inexact->exact (ceiling h))))))

(define (get-font size)
  (send the-font-list find-or-create-font size
        'default 'normal 'normal #f
        (case (system-type)
          [(macosx) 'partly-smoothed]
          [else 'smoothed])))

(define (a-rect/circ who do-draw w h color brush pen)
  (check-sizes who w h)
  (let* ([dc-proc (make-color-wrapper color brush pen do-draw)]
         [mask-proc (make-color-wrapper 'black brush pen do-draw)])
    (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) dc-proc mask-proc)))

(define (rectangle in-w in-h mode color)
  (check-size 'rectangle in-w "first")
  (check-size 'rectangle in-h "second")
  (check-mode 'rectangle mode "third")
  (check-image-color 'rectangle color "fourth")
  (let ([w (inexact->exact (floor in-w))]
        [h (inexact->exact (floor in-h))])
    (a-rect/circ 'rectangle
                 (lambda (dc dx dy) (send dc draw-rectangle dx dy w h))
                 w h color (mode->brush-symbol mode) (mode->pen-symbol mode))))

(define (ellipse in-w in-h mode color)
  (check-size 'ellipse in-w "first")
  (check-size 'ellipse in-h "second")
  (check-mode 'ellipse mode "third")
  (check-image-color 'ellipse color "fourth")
  (let ([w (inexact->exact (floor in-w))]
        [h (inexact->exact (floor in-h))])
    (a-rect/circ 'ellipse
                 (lambda (dc dx dy) (send dc draw-ellipse dx dy w h))
                 w h color (mode->brush-symbol mode) (mode->pen-symbol mode))))

(define (circle in-r mode color)
  (check-size 'circle in-r "first")
  (check-mode 'circle mode "second")
  (check-image-color 'circle color "third")
  (let ([r (inexact->exact (floor in-r))])
    (a-rect/circ 'circle
                 (lambda (dc dx dy) (send dc draw-ellipse dx dy (* 2 r) (* 2 r)))
                 (* 2 r) (* 2 r) color (mode->brush-symbol mode) (mode->pen-symbol mode))))

(define (triangle in-size mode color)
  (check 'triangle
         (lambda (x) (and (real? x) (< 2 x 10000)))
         in-size 
         "positive real number bigger than 2"
         "first")
  (check-mode 'triangle mode "second")
  (check-image-color 'triangle color "third")
  (let* ([size (floor (inexact->exact in-size))]
         [right (- size 1)]
         [bottom (inexact->exact (ceiling (* size (sin (* 2/3 pi)))))]
         [points (list (make-object point% 0 bottom)
                       (make-object point% right bottom)
                       (make-object point% (/ size 2) 0))]
         [draw (make-color-wrapper
                color (mode->brush-symbol mode) 'solid
                (lambda (dc dx dy)
                  (send dc draw-polygon points dx dy)))]
         [mask-draw (make-color-wrapper
                     'black (mode->brush-symbol mode) 'solid
                     (lambda (dc dx dy)
                       (send dc draw-polygon points dx dy)))]
         [w size]
         [h (+ bottom 1)])
    (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) draw mask-draw)))

(define (regular-polygon sides in-radius mode color [angle 0])
  (check 'regular-polygon 
         (λ (x) (and (integer? x) (<= 3 sides 10000)))
         sides
         "positive integer bigger than or equal to 3"
         "first")
  (check-size 'star in-radius "second")
  (check-mode 'regular-polygon mode "third")
  (check-image-color 'regular-polygon color "fourth")
  (check 'regular-polygon real? angle "real number" "fifth")
  (let* ([radius (inexact->exact (floor in-radius))]
         [points (regular-polygon-points radius sides angle)]
         [draw 
          (make-color-wrapper
           color (mode->brush-symbol mode) 'solid
           (λ (dc dx dy)
             (send dc draw-polygon points dx dy)))]
         [mask-draw 
          (make-color-wrapper
           'black (mode->brush-symbol mode) 'solid
           (λ (dc dx dy)
             (send dc draw-polygon points dx dy)))])
    (make-simple-cache-image-snip 
     (* radius 2)
     (* radius 2)
     radius
     radius
     draw
     mask-draw)))

(define (regular-polygon-points in-radius points delta-angle)
  (let ([radius (- in-radius 1)])
    (let loop ([n points])
      (cond
        [(zero? n) null]
        [else
         (let ([angle (+ delta-angle (* 2 pi n (/ 1 points)))])
           (cons (make-object point% 
                   (+ radius (* radius (cos angle)))
                   (+ radius (* radius (sin angle))))
                 (loop (- n 1))))]))))
  
(define (star points in-inner-radius in-outer-radius mode color)
  (check 'star
         (lambda (x) (and (integer? x) (<= 3 x 10000)))
         points
         "positive integer bigger than or equal to 3"
         "first")
  (check-size 'star in-inner-radius "second")
  (check-size 'star in-outer-radius "third")
  (check-mode 'star mode "fourth")
  (check-image-color 'star color "fifth")
  (let* ([inner-radius (inexact->exact (floor in-inner-radius))]
         [outer-radius (inexact->exact (floor in-outer-radius))]
         [points (star-points inner-radius outer-radius points)]
         [radial-offset
          (if (<= inner-radius outer-radius)
              0
              (- inner-radius outer-radius))]
         [draw 
          (make-color-wrapper
           color (mode->brush-symbol mode) 'solid
           (λ (dc dx dy)
             (send dc draw-polygon points 
                   (+ dx radial-offset)
                   (+ dy radial-offset))))]
         [mask-draw 
          (make-color-wrapper
           'black (mode->brush-symbol mode) 'solid
           (λ (dc dx dy)
             (send dc draw-polygon points
                   (+ dx radial-offset)
                   (+ dy radial-offset))))]
         
         ;; we want the radius to be this max -- if it draws outside
         ;; this radius, we should change the drawing.
         [size-determining-radius (max inner-radius outer-radius)])
    (make-simple-cache-image-snip 
     (* size-determining-radius 2)
     (* size-determining-radius 2)
     size-determining-radius
     size-determining-radius
     draw
     mask-draw)))

(define (star-points in-small-rad in-large-rad points)
  (let* ([small-rad (- in-small-rad 1)]
         [large-rad (- in-large-rad 1)]
         [roff (floor (/ large-rad 2))])
    (let loop ([i points])
      (cond
        [(zero? i) '()]
        [else 
         (let* ([this-p (- i 1)]
                [theta1 (* 2 pi (/ this-p points))]
                [theta2 (* 2 pi (/ (- this-p 1/2) points))])
           (let-values ([(x1 y1) (find-xy small-rad theta1)]
                        [(x2 y2) (find-xy large-rad theta2)])
             (let ([p1 (make-object point% 
                         (+ large-rad x1)
                         (+ large-rad y1))]
                   [p2 (make-object point%
                         (+ large-rad x2)
                         (+ large-rad y2))])
               (list* p1 p2 (loop (- i 1))))))]))))

(define (find-xy radius theta)
  (values (* radius (cos theta))
          (* radius (sin theta))))

(define (make-simple-cache-image-snip w h px py dc-proc mask-proc)
  (let ([w (inexact->exact (ceiling w))]
        [h (inexact->exact (ceiling h))])
    (let ([argb-proc 
           (lambda (argb-vector dx dy)
             (let ([c-bm (build-bitmap (lambda (dc) (dc-proc dc 0 0)) w h)]
                   [m-bm (build-bitmap (lambda (dc) (mask-proc dc 0 0)) w h)])
               (overlay-bitmap argb-vector dx dy c-bm m-bm)))])
      (new cache-image-snip%
           [dc-proc dc-proc]
           [argb-proc argb-proc]
           [width w]
           [height h]
           [px px]
           [py py]))))

(define (make-color-wrapper color-in brush pen rest)
  (let ([color (make-color% color-in)])
    (lambda (dc dx dy)
      (let ([old-brush (send dc get-brush)]
            [old-pen (send dc get-pen)])
        (send dc set-brush (send the-brush-list find-or-create-brush color brush))
        (send dc set-pen (send the-pen-list find-or-create-pen color 1 pen))
        (rest dc dx dy)
        (send dc set-pen old-pen)
        (send dc set-brush old-brush)))))


;; ------------------------------------------------------------

(define (image-inside? i a)
  (and (locate-image 'image-inside? 
                     (coerce-to-cache-image-snip i)
                     (coerce-to-cache-image-snip a))
       #t))

(define (find-image i a)
  (or (locate-image 'find-image 
                    (coerce-to-cache-image-snip i)
                    (coerce-to-cache-image-snip a))
      (error 'find-image
             "the second image does not appear within the first image")))

(define (locate-image who i a)
  (check-image who i "first")
  (check-image who a "second")
  (let-values ([(iw ih) (snip-size i)]
               [(ipx ipy) (send i get-pinhole)]
               [(aw ah) (snip-size a)]
               [(apx apy) (send a get-pinhole)])
    (and (iw . >= . aw)
         (ih . >= . ah)
         (let ([i-argb-vector (argb-vector (send i get-argb))]
               [a-argb-vector (argb-vector (send a get-argb))])
           (let ([al (let loop ([offset 0])
                       (cond
                         [(= offset (* ah aw 4)) null]
                         [else (cons (subvector a-argb-vector offset (+ offset (* 4 aw)))
                                     (loop (+ offset (* 4 aw))))]))])
             (let yloop ([dy 0])
               (and (dy . <= . (- ih ah))
                    (let xloop ([dx 0])
                      (if (dx . <= . (- iw aw))
                          (if (let loop ([al al][dd 0])
                                (or (null? al)
                                    (and (first-in-second?
                                          i-argb-vector 
                                          (car al)
                                          (* 4 (+ (* (+ dy dd) iw) dx)))
                                         (loop (cdr al) (add1 dd)))))
                              (make-posn (+ dx (- apx ipx)) (+ dy (- apy ipy)))
                              (xloop (add1 dx)))
                          (yloop (add1 dy)))))))))))

(define (subvector orig i j)
  (let ([v (make-vector (- j i) #f)])
    (let loop ([x i])
      (when (< x j)
        (vector-set! v (- x i) (vector-ref orig x))
        (loop (+ x 1))))
    v))
#|
(initial inequalities thanks to Matthew (thanks!!))

We know that, for a combination:
  m3 = (m1+m2-m1*m2) and 
  b3 = (m1*b1*(1-m2) + m2*b2)/m3

So, we need to figure out what m1 & m2 might have been, 
given the other values.

Check m3:

   m3 = m2 when m1 = 0
   m3 = 1 when m1 = 1

   [deriv of m3 with respect to m1 = 1 - m2, which is positive]

    so check that m3 is between m2 and 1

Then check m3*b3:

   b3*m3 = m2*b2  when m1 = 0 or b1 = 0
   b3*m3 = (1 - m2) + m2*b2 when m1 = b1 = 1

   [deriv with respect to m1 is b1*(1-m2), which is positive]
   [deriv with respect to b1 is m1*(1-m2), which is positive]

    So check that m3*b3 is between m2*b2 and (1 - m2) + m2*b2

This is all in alphas from 0 to 1 and needs to be from 255 to 0.
Converting (but using the same names) for the alpha test, we get:

(<= (- 1 (/ m2 255))
    (- 1 (/ m3 255))
    1)

sub1 to each:

(<= (- (/ m2 255))
    (- (/ m3 255))
    0)

mult by 255:

(<= (- m2)
    (- m3)
    0)

negate and flip ineq:


(>= m2 m3 0)

flip ineq back:

(<= 0 m3 m2)


Here's the original scheme expression for the second check:

(<= (* m2 b2) 
    (* m3 b3)
    (+ (- 1 m2) (* m2 b2))

converting from the computer's coordinates, we get:


(<= (* (- 1 (/ m2 255)) (- 1 (/ b2 255)))
    (* (- 1 (/ m3 255)) (- 1 (/ b3 255)))
    (+ (- 1 (- 1 (/ m2 255)))
       (* (- 1 (/ m2 255)) (- 1 (/ b2 255)))))

;; multiplying out the binomials:

(<= (+ 1
       (- (/ m2 255)) 
       (- (/ b2 255)) 
       (/ (* m2 b2) (* 255 255)))
    (+ 1
       (- (/ m3 255)) 
       (- (/ b3 255)) 
       (/ (* m3 b3) (* 255 255)))
    (+ (- 1 (- 1 (/ m2 255)))
       (+ 1
          (- (/ m2 255)) 
          (- (/ b2 255)) 
          (/ (* m2 b2) (* 255 255)))))

;; simplifying the last term
  
(<= (+ 1
       (- (/ m2 255)) 
       (- (/ b2 255)) 
       (/ (* m2 b2) (* 255 255)))
    (+ 1
       (- (/ m3 255)) 
       (- (/ b3 255)) 
       (/ (* m3 b3) (* 255 255)))
    (+ 1
       (- (/ b2 255)) 
       (/ (* m2 b2) (* 255 255))))
  
;; multiply thru by 255:

(<= (+ 255
       (- m2) 
       (- b2) 
       (* m2 b2 1/255))
    (+ 255
       (- m3)
       (- b3)
       (* m3 b3 1/255))
    (+ 255
       (- b2) 
       (* m2 b2 1/255)))
  
;; subtract out 255 from each:

(<= (+ (- m2) 
       (- b2) 
       (* m2 b2 1/255))
    (+ (- m3)
       (- b3)
       (* m3 b3 1/255))
    (+ (- b2) 
       (* m2 b2 1/255)))

;; negate them all, and reverse the inequality

(>= (+ m2 b2 (* m2 b2 -1/255))
    (+ m3 b3 (* m3 b3 -1/255))
    (+ b2 (* m2 b2 -1/255)))

;; aka

(<= (+ b2 (* m2 b2 -1/255))
    (+ m3 b3 (* m3 b3 -1/255))
    (+ m2 b2 (* m2 b2 -1/255)))

|#

;; in the above, m3 & b3 come from iv
;; and m2 & b2 come from av
(define (first-in-second? iv av xd)
  (let loop ([i (vector-length av)])
    (or (zero? i)
        (let ([a (- i 4)]
              [r (- i 3)]
              [g (- i 2)]
              [b (- i 1)])
          (let* ([m2 (vector-ref av a)]
                 [m3 (vector-ref iv (+ xd a))]
                 [test
                  (lambda (b2 b3)
                    (<= (+ b2 (* m2 b2 -1/255))
                        (+ m3 b3 (* m3 b3 -1/255))
                        (+ m2 b2 (* m2 b2 -1/255))))])
            (and (<= 0 m3 m2)
                 (test (vector-ref av r) (vector-ref iv (+ xd r)))
                 (test (vector-ref av g) (vector-ref iv (+ xd g)))
                 (test (vector-ref av b) (vector-ref iv (+ xd b)))
                 (loop (- i 4))))))))

;; ----------------------------------------

(define (image->color-list i-raw)
  (check-image 'image->color-list i-raw "first")
  (let* ([cis (coerce-to-cache-image-snip i-raw)]
         [i (send cis get-bitmap)]
         [iw (send i get-width)]
         [ih (send i get-height)]
         [new-bitmap (make-object bitmap% iw ih)]
         [bdc (make-object bitmap-dc% new-bitmap)])
    (send bdc clear)
    (send bdc draw-bitmap i 0 0 'solid 
          (send the-color-database find-color "black")
          (send i get-loaded-mask))
    (let ([is (make-bytes (* 4 iw ih))]
          [cols (make-vector (* iw ih))])
      (send bdc get-argb-pixels 0 0 iw ih is)
      (let yloop ([y 0][pos 0])
        (unless (= y ih)
          (let xloop ([x 0][pos pos])
            (if (= x iw)
                (yloop (add1 y) pos)
                (begin
                  (vector-set! cols (+ x (* y iw))
                               (make-color (bytes-ref is (+ 1 pos))
                                           (bytes-ref is (+ 2 pos))
                                           (bytes-ref is (+ 3 pos))))
                  (xloop (add1 x) (+ pos 4)))))))
      (send bdc set-bitmap #f)
      (vector->list cols))))

(define (image->alpha-color-list i)
  (check-image 'image->alpha-color-list i "first")
  (let* ([argb (cond
                 [(is-a? i image-snip%) 
                  (send (coerce-to-cache-image-snip i) get-argb)]
                 [(is-a? i cache-image-snip%) (send i get-argb)])]
         [v (argb-vector argb)])
    (let loop ([i (vector-length v)]
               [a null])
      (cond
        [(zero? i) a]
        [else (loop (- i 4)
                    (cons (make-alpha-color
                           (vector-ref v (- i 4))
                           (vector-ref v (- i 3))
                           (vector-ref v (- i 2))
                           (vector-ref v (- i 1)))
                          a))]))))

(define (color-list->image cl in-w in-h px py)
  (check 'color-list->image color-list? cl "list-of-colors" "first")
  (check-posi-size 'color-list->image in-w "second")
  (check-posi-size 'color-list->image in-h "third")
  (check-coordinate 'color-list->image px "fourth")
  (check-coordinate 'color-list->image py "fifth")
  (let ([w (inexact->exact in-w)]
        [h (inexact->exact in-h)])
    (unless (and (< 0 w 10000) (< 0 h 10000))
      (error 'color-list->image "cannot make ~a x ~a image" w h))
    (unless (= (* w h) (length cl))
      (error 'color-list->image
             "given width times given height is ~a, but the given color list has ~a items"
             (* w h) 
             (length cl)))
    (let* ([bm (make-object bitmap% w h)]
           [mask-bm (make-object bitmap% w h)]
           [dc (make-object bitmap-dc% bm)]
           [mask-dc (make-object bitmap-dc% mask-bm)])
      (unless (send bm ok?)
        (error (format "cannot make ~a x ~a image" w h)))
      (let ([is (make-bytes (* 4 w h) 0)]
            [mask-is (make-bytes (* 4 w h) 0)]
            [cols (list->vector (map (λ (x) 
                                       (or (make-color% x)
                                           (error 'color-list->image "color ~e is unknown" x)))
                                     cl))])
        (let yloop ([y 0][pos 0])
          (unless (= y h)
            (let xloop ([x 0][pos pos])
              (if (= x w)
                  (yloop (add1 y) pos)
                  (let* ([col (vector-ref cols (+ x (* y w)))]
                         [r (pk (send col red))]
                         [g (pk (send col green))]
                         [b (pk (send col blue))])
                    (bytes-set! is (+ 1 pos) r)
                    (bytes-set! is (+ 2 pos) g)
                    (bytes-set! is (+ 3 pos) b)
                    (when (= 255 r g b)
                      (bytes-set! mask-is (+ 1 pos) 255)
                      (bytes-set! mask-is (+ 2 pos) 255)
                      (bytes-set! mask-is (+ 3 pos) 255))
                    (xloop (add1 x) (+ pos 4)))))))
        (send dc set-argb-pixels 0 0 w h is)
        (send mask-dc set-argb-pixels 0 0 w h mask-is))
      (send dc set-bitmap #f)
      (send mask-dc set-bitmap #f)
      (bitmaps->cache-image-snip bm mask-bm px py))))

(define (pk col) (min 255 (max 0 col)))

(define (alpha-color-list->image cl in-w in-h px py)
  (check 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first")
  (check-posi-size 'alpha-color-list->image in-w "second")
  (check-posi-size 'alpha-color-list->image in-h "third")
  (check-coordinate 'alpha-color-list->image px "fourth")
  (check-coordinate 'alpha-color-list->image py "fifth")
  (let ([w (inexact->exact in-w)]
        [h (inexact->exact in-h)])
    (unless (and (< 0 w 10000) (< 0 h 10000))
      (error 'alpha-color-list->image format "cannot make ~a x ~a image" w h))
    (unless (= (* w h) (length cl))
      (error 'alpha-color-list->image
             "given width times given height is ~a, but the given color list has ~a items"
             (* w h) (length cl)))
    (let ([index-list (alpha-colors->ent-list cl)])
      (argb->cache-image-snip (make-argb (list->vector index-list) w) px py))))

;; alpha-colors->ent-list : (listof alpha-color) -> (listof number)
(define (alpha-colors->ent-list cl)
  (let loop ([cl cl])
    (cond
      [(null? cl) null]
      [else 
       (let ([ac (car cl)])
         (list* (alpha-color-alpha ac)
                (alpha-color-red ac)
                (alpha-color-green ac)
                (alpha-color-blue ac)
                (loop (cdr cl))))])))
<commit_msg>export as primitives<commit_after>#|

The test suite for this code is in
plt/collects/tests/mzscheme/image-test.ss

|#

#lang scheme/base

(require mred
         mzlib/class
         (lib "cache-image-snip.ss" "mrlib")
         mzlib/math
	 lang/prim
         (lib "posn.ss" "lang")
         (lib "imageeq.ss" "lang" "private")
         "error.ss")

(provide-primitives
         image-width
         image-height
         overlay
         overlay/xy
         
         pinhole-x
         pinhole-y
         move-pinhole
         put-pinhole
         
         rectangle
         circle
         ellipse
         triangle
         line
         star
         add-line
         text
         regular-polygon
         
         shrink
         shrink-tl
         shrink-tr
         shrink-bl
         shrink-br
         
         image-inside?
         find-image
         
         image->color-list
         color-list->image
         
         image->alpha-color-list
         alpha-color-list->image
         
         image-color?
         make-color
         color-red
         color-green
         color-blue
         color?
         make-alpha-color
         alpha-color-alpha
         alpha-color-red
         alpha-color-green
         alpha-color-blue
         alpha-color?)

;; ----------------------------------------

(define (color-list? l)
  (and (list? l) (andmap image-color? l)))
(define (alpha-color-list? l)
  (and (list? l) (andmap alpha-color? l)))

(define-struct color (red green blue) #:inspector (make-inspector))
(define-struct alpha-color (alpha red green blue) #:inspector (make-inspector))

;; ----------------------------------------

(define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v))

(define (check-coordinate name val arg-posn) (check name finite-real? val "finite real number" arg-posn))
(define (check-integer-coordinate name val arg-posn) (check name nii? val "integer" arg-posn))
(define (check-size name val arg-posn) (check name pos-number? val "positive number" arg-posn))
(define (check-posi-size name val arg-posn) (check name pos-integer? val "positive integer" arg-posn))
(define (check-size/0 name val arg-posn) (check name nn-number? val "non-negative number" arg-posn))
(define (check-image name val arg-posn) (check name image? val "image" arg-posn))
(define (check-image-color name val arg-posn) 
  (let ([simple-check (λ (x) (or (string? x) (symbol? x) (color? x)))])
    (check name simple-check val "image-color" arg-posn)
    (unless (image-color? val)
      (error name "~e is not a valid color name" val))))
(define (check-mode name val arg-posn) (check name mode? val mode-str arg-posn))

(define (pos-number? i) (and (number? i) (positive? i)))
(define (pos-integer? i) (and (number? i) (positive? i) (integer? i)))
(define (nn-number? i) (and (number? i) (or (zero? i) (positive? i))))
(define (nii? x) (and (integer? x) (not (= x +inf.0)) (not (= x -inf.0))))
(define (finite-real? x) (and (real? x) (not (= x +inf.0)) (not (= x -inf.0))))

(define (check-sizes who w h)
  (unless (and (< 0 w 10000) (< 0 h 10000))
    (error (format "cannot make ~a x ~a image" w h))))

(define (mode? x)
  (member x '(solid "solid" outline "outline")))

(define mode-str "'solid \"solid\" 'outline or \"outline\"")

(define (mode->brush-symbol m)
  (cond
    [(member m '(solid "solid"))
     'solid]
    [(member m '(outline "outline"))
     'transparent]))

(define (mode->pen-symbol m)
  (cond
    [(member m '(solid "solid")) 'transparent]
    [(member m '(outline "outline")) 'solid]))

(define (make-color% c)
  (cond
    [(string? c) (send the-color-database find-color c)]
    [(symbol? c) (send the-color-database find-color (symbol->string c))]
    [(color? c) (make-object color%
                  (color-red c)
                  (color-green c)
                  (color-blue c))]
    [else #f]))

(define (image-color? c) 
  (cond
    [(color? c) #t]
    [(string? c) (and (send the-color-database find-color c) #t)]
    [(symbol? c) (and (send the-color-database find-color (symbol->string c)) #t)]
    [else #f]))

(define (image-width a)
  (check-image 'image-width a "first")
  (let-values ([(w h) (snip-size a)])
    (inexact->exact (ceiling w))))

(define (image-height a)
  (check-image 'image-height a "first")
  (let-values ([(w h) (snip-size a)])
    (inexact->exact (ceiling h))))

(define (pinhole-x a)
  (check-image 'pinhole-x a "first")
  (let-values ([(x y) (send (coerce-to-cache-image-snip a) get-pinhole)])
    x))

(define (pinhole-y a)
  (check-image 'pinhole-y a "first")
  (let-values ([(x y) (send (coerce-to-cache-image-snip a) get-pinhole)])
    y))

(define (move-pinhole raw-i dx dy)
  (check-image 'move-pinhole raw-i "first")
  (check-coordinate 'move-pinhole dx "second")
  (check-coordinate 'move-pinhole dy "third")
  (let ([i (coerce-to-cache-image-snip raw-i)])
    (let-values ([(px py) (send i get-pinhole)]
                 [(w h) (send i get-size)])
      (new cache-image-snip%
           (dc-proc (send i get-dc-proc))
           (argb-proc (send i get-argb-proc))
           (width w)
           (height h)
           (argb (send i get-argb/no-compute))
           (px (+ px dx))
           (py (+ py dy))))))

(define (put-pinhole raw-i px py)
  (check-image 'put-pinhole raw-i "first")
  (check-coordinate 'put-pinhole px "second")
  (check-coordinate 'put-pinhole py "third")
  (let ([i (coerce-to-cache-image-snip raw-i)])
    (let-values ([(w h) (send i get-size)])
      (new cache-image-snip%
           (dc-proc (send i get-dc-proc))
           (argb-proc (send i get-argb-proc))
           (width w)
           (height h)
           (argb (send i get-argb/no-compute))
           (px (floor px))
           (py (floor py))))))

(define (overlay a b . cs)
  (check-image 'overlay a "first")
  (check-image 'overlay b "second")
  (let loop ([cs cs]
             [i 3])
    (unless (null? cs)
      (check-image 'overlay (car cs) (number->ord i))))
  (let ([all-imgs (reverse (list* a b cs))])
    (let loop ([imgs (cdr all-imgs)]
               [acc (car all-imgs)])
      (cond
        [(null? imgs) acc]
        [else (loop (cdr imgs)
                    (real-overlay/xy 'overlay (car imgs) 0 0 acc))]))))

(define (overlay/xy a dx dy b)
  (check-image 'overlay/xy a "first")
  (check-coordinate 'overlay/xy dx "second")
  (check-coordinate 'overlay/xy dy "third")
  (check-image 'overlay/xy b "fourth")
  (real-overlay/xy 'overlay/xy 
                   a
                   (floor (if (exact? dx) dx (inexact->exact dx)))
                   (floor (if (exact? dy) dy (inexact->exact dy)))
                   b))

(define (real-overlay/xy name raw-a raw-delta-x raw-delta-y raw-b)
  (let ([a (coerce-to-cache-image-snip raw-a)]
        [b (coerce-to-cache-image-snip raw-b)])
    (let-values ([(a-w a-h) (snip-size a)]
                 [(b-w b-h) (snip-size b)]
                 [(a-px a-py) (send a get-pinhole)]
                 [(b-px b-py) (send b get-pinhole)])
      (let* ([delta-x (+ raw-delta-x a-px (- b-px))]
             [delta-y (+ raw-delta-y a-py (- b-py))]
             [left (min 0 delta-x)]
             [top (min 0 delta-y)]
             [right (max (+ delta-x b-w) a-w)]
             [bottom (max (+ delta-y b-h) a-h)]
             [new-w (inexact->exact (ceiling (- right left)))]
             [new-h (inexact->exact (ceiling (- bottom top)))]
             [a-dx (inexact->exact (round (- left)))]
             [a-dy (inexact->exact (round (- top)))]
             [b-dx (inexact->exact (round (- delta-x left)))]
             [b-dy (inexact->exact (round (- delta-y top)))]
             [new-px (- a-px left)]
             [new-py (- a-py top)]
             [combine (lambda (a-f b-f)
                        (lambda (dc dx dy)
                          (a-f dc (+ dx a-dx) (+ dy a-dy))
                          (b-f dc (+ dx b-dx) (+ dy b-dy))))])
        (check-sizes name new-w new-h)
        (new cache-image-snip%
             [dc-proc (combine (send a get-dc-proc)
                               (send b get-dc-proc))]
             [argb-proc (combine (send a get-argb-proc)
                                 (send b get-argb-proc))]
             [width new-w]
             [height new-h]
             [px new-px]
             [py new-py])))))
;; ------------------------------------------------------------

(define (shrink raw-img in-left in-up in-right in-down)
  (check-image 'shrink raw-img "first")
  (check-size/0 'shrink in-left "second")
  (check-size/0 'shrink in-up "third")
  (check-size/0 'shrink in-right "fourth")
  (check-size/0 'shrink in-down "fifth")
  (let ([left (inexact->exact (floor in-left))]
        [up (inexact->exact (floor in-up))]
        [right (inexact->exact (floor in-right))]
        [down (inexact->exact (floor in-down))]
        [img (coerce-to-cache-image-snip raw-img)])
    (let-values ([(i-px i-py) (send img get-pinhole)]
                 [(i-width i-height) (send img get-size)])
      (let* ([dc-proc (send img get-dc-proc)]
             [argb-proc (send img get-argb-proc)]
             [delta-w (- i-px left)]
             [delta-h (- i-py up)]
             [width (+ left right 1)]
             [height (+ up down 1)])
        (new cache-image-snip%
             [px left]
             [py up]
             [dc-proc (lambda (dc dx dy)
                        (let ([clip (send dc get-clipping-region)]
                              [rgn (make-object region% dc)])
                          (send rgn set-rectangle dx dy width height)
                          (when clip
                            (send rgn intersect clip))
                          (send dc set-clipping-region rgn)
                          (dc-proc dc (- dx delta-w) (- dy delta-h))
                          (send dc set-clipping-region clip)))]
             [argb-proc (lambda (argb dx dy) (argb-proc argb (- dx delta-w) (- dy delta-h)))]
             [width width]
             [height height])))))

(define (shrink-tl raw-img in-x in-y)
  (check-image 'shrink-tl raw-img "first")
  (check-size 'shrink-tl in-x "second")
  (check-size 'shrink-tl in-y "third")
  (let ([x (inexact->exact (floor in-x))]
        [y (inexact->exact (floor in-y))])
    (put-pinhole (shrink (put-pinhole raw-img 0 0) 0 0 (- x 1) (- y 1)) (/ x 2) (/ y 2))))

(define (shrink-tr raw-img in-x in-y)
  (check-image 'shrink-tr raw-img "first")
  (check-size 'shrink-tr in-x "second")
  (check-size 'shrink-tr in-y "third")
  (let ([x (inexact->exact (floor in-x))]
        [y (inexact->exact (floor in-y))])
    (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) 0) (- x 1) 0 0 (- y 1))
                 (/ x 2)
                 (/ y 2))))

(define (shrink-bl raw-img in-x in-y)
  (check-image 'shrink-bl raw-img "first")
  (check-size 'shrink-bl in-x "second")
  (check-size 'shrink-bl in-y "third")
  (let ([x (inexact->exact (floor in-x))]
        [y (inexact->exact (floor in-y))])
    (put-pinhole (shrink (put-pinhole raw-img 0 (- (image-height raw-img) 1)) 0 (- y 1) (- x 1) 0) 
                 (/ x 2)
                 (/ y 2))))

(define (shrink-br raw-img in-x in-y)
  (check-image 'shrink-br raw-img "first")
  (check-size 'shrink-br in-x "second")
  (check-size 'shrink-br in-y "third")
  (let ([x (inexact->exact (floor in-x))]
        [y (inexact->exact (floor in-y))])
    (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) (- (image-height raw-img) 1))
                         (- x 1)
                         (- y 1)
                         0
                         0)
                 (/ x 2)
                 (/ y 2))))


;; ------------------------------------------------------------

(define (line in-x in-y color)
  (check-coordinate 'line in-x "first")
  (check-coordinate 'line in-y "second")
  (check-image-color 'line color "third")
  (let* ([x (floor (inexact->exact in-x))]
         [y (floor (inexact->exact in-y))]
         [w (+ (abs x) 1)]
         [h (+ (abs y) 1)]
         [px (abs (min x 0))]
         [py (abs (min y 0))])
    (check-sizes 'line w h)
    (let* ([do-draw
            (λ (dc dx dy)
              (send dc draw-line (+ px dx) (+ py dy) (+ dx px x) (+ dy py y)))]
           [draw-proc (make-color-wrapper color 'transparent 'solid do-draw)]
           [mask-proc (make-color-wrapper 'black 'transparent 'solid do-draw)])
      (make-simple-cache-image-snip w h px py draw-proc mask-proc))))

;; test what happens when the line moves out of the box.
(define (add-line raw-i pre-x1 pre-y1 pre-x2 pre-y2 color-in)
  (check-image 'add-line raw-i "first")
  (check-coordinate 'add-line pre-x1 "second")
  (check-coordinate 'add-line pre-y1 "third")
  (check-coordinate 'add-line pre-x2 "fourth")
  (check-coordinate 'add-line pre-y2 "fifth")
  (check-image-color 'add-line color-in "sixth")
  (let ([i (coerce-to-cache-image-snip raw-i)])
    (let-values ([(px py) (send i get-pinhole)]
                 [(iw ih) (send i get-size)]
                 [(x1 y1 x2 y2)
                  (if (<= pre-x1 pre-x2)
                      (values pre-x1 pre-y1 pre-x2 pre-y2)
                      (values pre-x2 pre-y2 pre-x1 pre-y1))])
      (let* ([line-w (abs (- x2 x1))]
             [line-h (abs (- y2 y1))]
             [build-snip
              (λ (do-draw py-offset)
                (let* ([draw-proc 
                        (make-color-wrapper color-in 'transparent 'solid do-draw)]
                       [mask-proc
                        (make-color-wrapper 'black 'transparent 'solid do-draw)]
                       [line
                        (make-simple-cache-image-snip (+ line-w 1) (+ line-h 1) px py draw-proc mask-proc)])
                  (real-overlay/xy 'add-line i (+ px x1) (+ py py-offset) line)))])
        (if (y1 . <= . y2)
            (build-snip (λ (dc dx dy)
                          (send dc draw-line 
                                dx
                                dy
                                (+ dx (- x2 x1))
                                (+ dy (- y2 y1))))
                        y1)
            (build-snip (λ (dc dx dy)
                          (send dc draw-line 
                                dx
                                (+ dy line-h)
                                (+ dx line-w)
                                dy))
                        y2))))))

(define (text str size color-in)
  (check 'text (lambda (x) (and (string? x) (not (equal? "" x)))) str "non-empty string" "first")
  (check 'text (lambda (x) (and (integer? x) (<= 1 x 255))) size "integer between 1 and 255" "second")
  (check-image-color 'text color-in "third")
  (let ([color (make-color% color-in)])
    (let-values ([(tw th) (get-text-size size str)])
      (let ([draw-proc
             (lambda (txt-color mode dc dx dy)
               (let ([old-mode (send dc get-text-mode)]
                     [old-fore (send dc get-text-foreground)]
                     [old-font (send dc get-font)])
                 (send dc set-text-mode mode)
                 (send dc set-text-foreground txt-color)
                 (send dc set-font (get-font size))
                 (send dc draw-text str dx dy)
                 (send dc set-text-mode old-mode)
                 (send dc set-text-foreground old-fore)
                 (send dc set-font old-font)))])
        (new cache-image-snip%
             [dc-proc (lambda (dc dx dy) (draw-proc color 'transparent dc dx dy))]
             [argb-proc 
              (lambda (argb dx dy)
                (let ([bm-color
                       (build-bitmap
                        (lambda (dc)
                          (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
                          (send dc set-brush (send the-brush-list find-or-create-brush color 'solid))
                          (send dc draw-rectangle 0 0 tw th))
                        tw
                        th)]
                      [bm-mask
                       (build-bitmap
                        (lambda (dc)
                          (draw-proc 
                           (send the-color-database find-color "black")
                           'solid dc 0 0))
                        tw
                        th)])
                  (overlay-bitmap argb dx dy bm-color bm-mask)))]
             [width tw]
             [height th]
             [px 0]
             [py 0])))))

(define cached-bdc-for-text-size (make-thread-cell #f))
(define (get-text-size size string)
  (unless (thread-cell-ref cached-bdc-for-text-size)
    (let* ([bm (make-object bitmap% 1 1)]
           [dc (make-object bitmap-dc% bm)])
      (thread-cell-set! cached-bdc-for-text-size dc)))
  (let ([dc (thread-cell-ref cached-bdc-for-text-size)])
    (let-values ([(w h _1 _2) (send dc get-text-extent string (get-font size))])
      (values (inexact->exact (ceiling w)) 
              (inexact->exact (ceiling h))))))

(define (get-font size)
  (send the-font-list find-or-create-font size
        'default 'normal 'normal #f
        (case (system-type)
          [(macosx) 'partly-smoothed]
          [else 'smoothed])))

(define (a-rect/circ who do-draw w h color brush pen)
  (check-sizes who w h)
  (let* ([dc-proc (make-color-wrapper color brush pen do-draw)]
         [mask-proc (make-color-wrapper 'black brush pen do-draw)])
    (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) dc-proc mask-proc)))

(define (rectangle in-w in-h mode color)
  (check-size 'rectangle in-w "first")
  (check-size 'rectangle in-h "second")
  (check-mode 'rectangle mode "third")
  (check-image-color 'rectangle color "fourth")
  (let ([w (inexact->exact (floor in-w))]
        [h (inexact->exact (floor in-h))])
    (a-rect/circ 'rectangle
                 (lambda (dc dx dy) (send dc draw-rectangle dx dy w h))
                 w h color (mode->brush-symbol mode) (mode->pen-symbol mode))))

(define (ellipse in-w in-h mode color)
  (check-size 'ellipse in-w "first")
  (check-size 'ellipse in-h "second")
  (check-mode 'ellipse mode "third")
  (check-image-color 'ellipse color "fourth")
  (let ([w (inexact->exact (floor in-w))]
        [h (inexact->exact (floor in-h))])
    (a-rect/circ 'ellipse
                 (lambda (dc dx dy) (send dc draw-ellipse dx dy w h))
                 w h color (mode->brush-symbol mode) (mode->pen-symbol mode))))

(define (circle in-r mode color)
  (check-size 'circle in-r "first")
  (check-mode 'circle mode "second")
  (check-image-color 'circle color "third")
  (let ([r (inexact->exact (floor in-r))])
    (a-rect/circ 'circle
                 (lambda (dc dx dy) (send dc draw-ellipse dx dy (* 2 r) (* 2 r)))
                 (* 2 r) (* 2 r) color (mode->brush-symbol mode) (mode->pen-symbol mode))))

(define (triangle in-size mode color)
  (check 'triangle
         (lambda (x) (and (real? x) (< 2 x 10000)))
         in-size 
         "positive real number bigger than 2"
         "first")
  (check-mode 'triangle mode "second")
  (check-image-color 'triangle color "third")
  (let* ([size (floor (inexact->exact in-size))]
         [right (- size 1)]
         [bottom (inexact->exact (ceiling (* size (sin (* 2/3 pi)))))]
         [points (list (make-object point% 0 bottom)
                       (make-object point% right bottom)
                       (make-object point% (/ size 2) 0))]
         [draw (make-color-wrapper
                color (mode->brush-symbol mode) 'solid
                (lambda (dc dx dy)
                  (send dc draw-polygon points dx dy)))]
         [mask-draw (make-color-wrapper
                     'black (mode->brush-symbol mode) 'solid
                     (lambda (dc dx dy)
                       (send dc draw-polygon points dx dy)))]
         [w size]
         [h (+ bottom 1)])
    (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) draw mask-draw)))

(define (regular-polygon sides in-radius mode color [angle 0])
  (check 'regular-polygon 
         (λ (x) (and (integer? x) (<= 3 sides 10000)))
         sides
         "positive integer bigger than or equal to 3"
         "first")
  (check-size 'star in-radius "second")
  (check-mode 'regular-polygon mode "third")
  (check-image-color 'regular-polygon color "fourth")
  (check 'regular-polygon real? angle "real number" "fifth")
  (let* ([radius (inexact->exact (floor in-radius))]
         [points (regular-polygon-points radius sides angle)]
         [draw 
          (make-color-wrapper
           color (mode->brush-symbol mode) 'solid
           (λ (dc dx dy)
             (send dc draw-polygon points dx dy)))]
         [mask-draw 
          (make-color-wrapper
           'black (mode->brush-symbol mode) 'solid
           (λ (dc dx dy)
             (send dc draw-polygon points dx dy)))])
    (make-simple-cache-image-snip 
     (* radius 2)
     (* radius 2)
     radius
     radius
     draw
     mask-draw)))

(define (regular-polygon-points in-radius points delta-angle)
  (let ([radius (- in-radius 1)])
    (let loop ([n points])
      (cond
        [(zero? n) null]
        [else
         (let ([angle (+ delta-angle (* 2 pi n (/ 1 points)))])
           (cons (make-object point% 
                   (+ radius (* radius (cos angle)))
                   (+ radius (* radius (sin angle))))
                 (loop (- n 1))))]))))
  
(define (star points in-inner-radius in-outer-radius mode color)
  (check 'star
         (lambda (x) (and (integer? x) (<= 3 x 10000)))
         points
         "positive integer bigger than or equal to 3"
         "first")
  (check-size 'star in-inner-radius "second")
  (check-size 'star in-outer-radius "third")
  (check-mode 'star mode "fourth")
  (check-image-color 'star color "fifth")
  (let* ([inner-radius (inexact->exact (floor in-inner-radius))]
         [outer-radius (inexact->exact (floor in-outer-radius))]
         [points (star-points inner-radius outer-radius points)]
         [radial-offset
          (if (<= inner-radius outer-radius)
              0
              (- inner-radius outer-radius))]
         [draw 
          (make-color-wrapper
           color (mode->brush-symbol mode) 'solid
           (λ (dc dx dy)
             (send dc draw-polygon points 
                   (+ dx radial-offset)
                   (+ dy radial-offset))))]
         [mask-draw 
          (make-color-wrapper
           'black (mode->brush-symbol mode) 'solid
           (λ (dc dx dy)
             (send dc draw-polygon points
                   (+ dx radial-offset)
                   (+ dy radial-offset))))]
         
         ;; we want the radius to be this max -- if it draws outside
         ;; this radius, we should change the drawing.
         [size-determining-radius (max inner-radius outer-radius)])
    (make-simple-cache-image-snip 
     (* size-determining-radius 2)
     (* size-determining-radius 2)
     size-determining-radius
     size-determining-radius
     draw
     mask-draw)))

(define (star-points in-small-rad in-large-rad points)
  (let* ([small-rad (- in-small-rad 1)]
         [large-rad (- in-large-rad 1)]
         [roff (floor (/ large-rad 2))])
    (let loop ([i points])
      (cond
        [(zero? i) '()]
        [else 
         (let* ([this-p (- i 1)]
                [theta1 (* 2 pi (/ this-p points))]
                [theta2 (* 2 pi (/ (- this-p 1/2) points))])
           (let-values ([(x1 y1) (find-xy small-rad theta1)]
                        [(x2 y2) (find-xy large-rad theta2)])
             (let ([p1 (make-object point% 
                         (+ large-rad x1)
                         (+ large-rad y1))]
                   [p2 (make-object point%
                         (+ large-rad x2)
                         (+ large-rad y2))])
               (list* p1 p2 (loop (- i 1))))))]))))

(define (find-xy radius theta)
  (values (* radius (cos theta))
          (* radius (sin theta))))

(define (make-simple-cache-image-snip w h px py dc-proc mask-proc)
  (let ([w (inexact->exact (ceiling w))]
        [h (inexact->exact (ceiling h))])
    (let ([argb-proc 
           (lambda (argb-vector dx dy)
             (let ([c-bm (build-bitmap (lambda (dc) (dc-proc dc 0 0)) w h)]
                   [m-bm (build-bitmap (lambda (dc) (mask-proc dc 0 0)) w h)])
               (overlay-bitmap argb-vector dx dy c-bm m-bm)))])
      (new cache-image-snip%
           [dc-proc dc-proc]
           [argb-proc argb-proc]
           [width w]
           [height h]
           [px px]
           [py py]))))

(define (make-color-wrapper color-in brush pen rest)
  (let ([color (make-color% color-in)])
    (lambda (dc dx dy)
      (let ([old-brush (send dc get-brush)]
            [old-pen (send dc get-pen)])
        (send dc set-brush (send the-brush-list find-or-create-brush color brush))
        (send dc set-pen (send the-pen-list find-or-create-pen color 1 pen))
        (rest dc dx dy)
        (send dc set-pen old-pen)
        (send dc set-brush old-brush)))))


;; ------------------------------------------------------------

(define (image-inside? i a)
  (and (locate-image 'image-inside? 
                     (coerce-to-cache-image-snip i)
                     (coerce-to-cache-image-snip a))
       #t))

(define (find-image i a)
  (or (locate-image 'find-image 
                    (coerce-to-cache-image-snip i)
                    (coerce-to-cache-image-snip a))
      (error 'find-image
             "the second image does not appear within the first image")))

(define (locate-image who i a)
  (check-image who i "first")
  (check-image who a "second")
  (let-values ([(iw ih) (snip-size i)]
               [(ipx ipy) (send i get-pinhole)]
               [(aw ah) (snip-size a)]
               [(apx apy) (send a get-pinhole)])
    (and (iw . >= . aw)
         (ih . >= . ah)
         (let ([i-argb-vector (argb-vector (send i get-argb))]
               [a-argb-vector (argb-vector (send a get-argb))])
           (let ([al (let loop ([offset 0])
                       (cond
                         [(= offset (* ah aw 4)) null]
                         [else (cons (subvector a-argb-vector offset (+ offset (* 4 aw)))
                                     (loop (+ offset (* 4 aw))))]))])
             (let yloop ([dy 0])
               (and (dy . <= . (- ih ah))
                    (let xloop ([dx 0])
                      (if (dx . <= . (- iw aw))
                          (if (let loop ([al al][dd 0])
                                (or (null? al)
                                    (and (first-in-second?
                                          i-argb-vector 
                                          (car al)
                                          (* 4 (+ (* (+ dy dd) iw) dx)))
                                         (loop (cdr al) (add1 dd)))))
                              (make-posn (+ dx (- apx ipx)) (+ dy (- apy ipy)))
                              (xloop (add1 dx)))
                          (yloop (add1 dy)))))))))))

(define (subvector orig i j)
  (let ([v (make-vector (- j i) #f)])
    (let loop ([x i])
      (when (< x j)
        (vector-set! v (- x i) (vector-ref orig x))
        (loop (+ x 1))))
    v))
#|
(initial inequalities thanks to Matthew (thanks!!))

We know that, for a combination:
  m3 = (m1+m2-m1*m2) and 
  b3 = (m1*b1*(1-m2) + m2*b2)/m3

So, we need to figure out what m1 & m2 might have been, 
given the other values.

Check m3:

   m3 = m2 when m1 = 0
   m3 = 1 when m1 = 1

   [deriv of m3 with respect to m1 = 1 - m2, which is positive]

    so check that m3 is between m2 and 1

Then check m3*b3:

   b3*m3 = m2*b2  when m1 = 0 or b1 = 0
   b3*m3 = (1 - m2) + m2*b2 when m1 = b1 = 1

   [deriv with respect to m1 is b1*(1-m2), which is positive]
   [deriv with respect to b1 is m1*(1-m2), which is positive]

    So check that m3*b3 is between m2*b2 and (1 - m2) + m2*b2

This is all in alphas from 0 to 1 and needs to be from 255 to 0.
Converting (but using the same names) for the alpha test, we get:

(<= (- 1 (/ m2 255))
    (- 1 (/ m3 255))
    1)

sub1 to each:

(<= (- (/ m2 255))
    (- (/ m3 255))
    0)

mult by 255:

(<= (- m2)
    (- m3)
    0)

negate and flip ineq:


(>= m2 m3 0)

flip ineq back:

(<= 0 m3 m2)


Here's the original scheme expression for the second check:

(<= (* m2 b2) 
    (* m3 b3)
    (+ (- 1 m2) (* m2 b2))

converting from the computer's coordinates, we get:


(<= (* (- 1 (/ m2 255)) (- 1 (/ b2 255)))
    (* (- 1 (/ m3 255)) (- 1 (/ b3 255)))
    (+ (- 1 (- 1 (/ m2 255)))
       (* (- 1 (/ m2 255)) (- 1 (/ b2 255)))))

;; multiplying out the binomials:

(<= (+ 1
       (- (/ m2 255)) 
       (- (/ b2 255)) 
       (/ (* m2 b2) (* 255 255)))
    (+ 1
       (- (/ m3 255)) 
       (- (/ b3 255)) 
       (/ (* m3 b3) (* 255 255)))
    (+ (- 1 (- 1 (/ m2 255)))
       (+ 1
          (- (/ m2 255)) 
          (- (/ b2 255)) 
          (/ (* m2 b2) (* 255 255)))))

;; simplifying the last term
  
(<= (+ 1
       (- (/ m2 255)) 
       (- (/ b2 255)) 
       (/ (* m2 b2) (* 255 255)))
    (+ 1
       (- (/ m3 255)) 
       (- (/ b3 255)) 
       (/ (* m3 b3) (* 255 255)))
    (+ 1
       (- (/ b2 255)) 
       (/ (* m2 b2) (* 255 255))))
  
;; multiply thru by 255:

(<= (+ 255
       (- m2) 
       (- b2) 
       (* m2 b2 1/255))
    (+ 255
       (- m3)
       (- b3)
       (* m3 b3 1/255))
    (+ 255
       (- b2) 
       (* m2 b2 1/255)))
  
;; subtract out 255 from each:

(<= (+ (- m2) 
       (- b2) 
       (* m2 b2 1/255))
    (+ (- m3)
       (- b3)
       (* m3 b3 1/255))
    (+ (- b2) 
       (* m2 b2 1/255)))

;; negate them all, and reverse the inequality

(>= (+ m2 b2 (* m2 b2 -1/255))
    (+ m3 b3 (* m3 b3 -1/255))
    (+ b2 (* m2 b2 -1/255)))

;; aka

(<= (+ b2 (* m2 b2 -1/255))
    (+ m3 b3 (* m3 b3 -1/255))
    (+ m2 b2 (* m2 b2 -1/255)))

|#

;; in the above, m3 & b3 come from iv
;; and m2 & b2 come from av
(define (first-in-second? iv av xd)
  (let loop ([i (vector-length av)])
    (or (zero? i)
        (let ([a (- i 4)]
              [r (- i 3)]
              [g (- i 2)]
              [b (- i 1)])
          (let* ([m2 (vector-ref av a)]
                 [m3 (vector-ref iv (+ xd a))]
                 [test
                  (lambda (b2 b3)
                    (<= (+ b2 (* m2 b2 -1/255))
                        (+ m3 b3 (* m3 b3 -1/255))
                        (+ m2 b2 (* m2 b2 -1/255))))])
            (and (<= 0 m3 m2)
                 (test (vector-ref av r) (vector-ref iv (+ xd r)))
                 (test (vector-ref av g) (vector-ref iv (+ xd g)))
                 (test (vector-ref av b) (vector-ref iv (+ xd b)))
                 (loop (- i 4))))))))

;; ----------------------------------------

(define (image->color-list i-raw)
  (check-image 'image->color-list i-raw "first")
  (let* ([cis (coerce-to-cache-image-snip i-raw)]
         [i (send cis get-bitmap)]
         [iw (send i get-width)]
         [ih (send i get-height)]
         [new-bitmap (make-object bitmap% iw ih)]
         [bdc (make-object bitmap-dc% new-bitmap)])
    (send bdc clear)
    (send bdc draw-bitmap i 0 0 'solid 
          (send the-color-database find-color "black")
          (send i get-loaded-mask))
    (let ([is (make-bytes (* 4 iw ih))]
          [cols (make-vector (* iw ih))])
      (send bdc get-argb-pixels 0 0 iw ih is)
      (let yloop ([y 0][pos 0])
        (unless (= y ih)
          (let xloop ([x 0][pos pos])
            (if (= x iw)
                (yloop (add1 y) pos)
                (begin
                  (vector-set! cols (+ x (* y iw))
                               (make-color (bytes-ref is (+ 1 pos))
                                           (bytes-ref is (+ 2 pos))
                                           (bytes-ref is (+ 3 pos))))
                  (xloop (add1 x) (+ pos 4)))))))
      (send bdc set-bitmap #f)
      (vector->list cols))))

(define (image->alpha-color-list i)
  (check-image 'image->alpha-color-list i "first")
  (let* ([argb (cond
                 [(is-a? i image-snip%) 
                  (send (coerce-to-cache-image-snip i) get-argb)]
                 [(is-a? i cache-image-snip%) (send i get-argb)])]
         [v (argb-vector argb)])
    (let loop ([i (vector-length v)]
               [a null])
      (cond
        [(zero? i) a]
        [else (loop (- i 4)
                    (cons (make-alpha-color
                           (vector-ref v (- i 4))
                           (vector-ref v (- i 3))
                           (vector-ref v (- i 2))
                           (vector-ref v (- i 1)))
                          a))]))))

(define (color-list->image cl in-w in-h px py)
  (check 'color-list->image color-list? cl "list-of-colors" "first")
  (check-posi-size 'color-list->image in-w "second")
  (check-posi-size 'color-list->image in-h "third")
  (check-coordinate 'color-list->image px "fourth")
  (check-coordinate 'color-list->image py "fifth")
  (let ([w (inexact->exact in-w)]
        [h (inexact->exact in-h)])
    (unless (and (< 0 w 10000) (< 0 h 10000))
      (error 'color-list->image "cannot make ~a x ~a image" w h))
    (unless (= (* w h) (length cl))
      (error 'color-list->image
             "given width times given height is ~a, but the given color list has ~a items"
             (* w h) 
             (length cl)))
    (let* ([bm (make-object bitmap% w h)]
           [mask-bm (make-object bitmap% w h)]
           [dc (make-object bitmap-dc% bm)]
           [mask-dc (make-object bitmap-dc% mask-bm)])
      (unless (send bm ok?)
        (error (format "cannot make ~a x ~a image" w h)))
      (let ([is (make-bytes (* 4 w h) 0)]
            [mask-is (make-bytes (* 4 w h) 0)]
            [cols (list->vector (map (λ (x) 
                                       (or (make-color% x)
                                           (error 'color-list->image "color ~e is unknown" x)))
                                     cl))])
        (let yloop ([y 0][pos 0])
          (unless (= y h)
            (let xloop ([x 0][pos pos])
              (if (= x w)
                  (yloop (add1 y) pos)
                  (let* ([col (vector-ref cols (+ x (* y w)))]
                         [r (pk (send col red))]
                         [g (pk (send col green))]
                         [b (pk (send col blue))])
                    (bytes-set! is (+ 1 pos) r)
                    (bytes-set! is (+ 2 pos) g)
                    (bytes-set! is (+ 3 pos) b)
                    (when (= 255 r g b)
                      (bytes-set! mask-is (+ 1 pos) 255)
                      (bytes-set! mask-is (+ 2 pos) 255)
                      (bytes-set! mask-is (+ 3 pos) 255))
                    (xloop (add1 x) (+ pos 4)))))))
        (send dc set-argb-pixels 0 0 w h is)
        (send mask-dc set-argb-pixels 0 0 w h mask-is))
      (send dc set-bitmap #f)
      (send mask-dc set-bitmap #f)
      (bitmaps->cache-image-snip bm mask-bm px py))))

(define (pk col) (min 255 (max 0 col)))

(define (alpha-color-list->image cl in-w in-h px py)
  (check 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first")
  (check-posi-size 'alpha-color-list->image in-w "second")
  (check-posi-size 'alpha-color-list->image in-h "third")
  (check-coordinate 'alpha-color-list->image px "fourth")
  (check-coordinate 'alpha-color-list->image py "fifth")
  (let ([w (inexact->exact in-w)]
        [h (inexact->exact in-h)])
    (unless (and (< 0 w 10000) (< 0 h 10000))
      (error 'alpha-color-list->image format "cannot make ~a x ~a image" w h))
    (unless (= (* w h) (length cl))
      (error 'alpha-color-list->image
             "given width times given height is ~a, but the given color list has ~a items"
             (* w h) (length cl)))
    (let ([index-list (alpha-colors->ent-list cl)])
      (argb->cache-image-snip (make-argb (list->vector index-list) w) px py))))

;; alpha-colors->ent-list : (listof alpha-color) -> (listof number)
(define (alpha-colors->ent-list cl)
  (let loop ([cl cl])
    (cond
      [(null? cl) null]
      [else 
       (let ([ac (car cl)])
         (list* (alpha-color-alpha ac)
                (alpha-color-red ac)
                (alpha-color-green ac)
                (alpha-color-blue ac)
                (loop (cdr cl))))])))

{'fraction_non_alphanumeric': 0.1691340106434446, 'fraction_numerical': 0.01896468311562651, 'mean_word_length': 1.552157194764878, 'pattern_counts': {'":': 0, '<': 61, '<?xml version=': 0, '>': 197, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 54, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4189283', 'n_tokens_mistral': 25726, 'n_tokens_neox': 23874, 'n_words': 7205}