working on clipart test

image/private/js-impl.js

@@ -4,6 +4,7 @@ var makeClosure = plt.baselib.functions.makeClosure;
 var finalizeClosureCall = plt.baselib.functions.finalizeClosureCall;
 var PAUSE = plt.runtime.PAUSE;
 
+var checkSymbolOrString = plt.baselib.check.checkSymbolOrString;
 
 var isString = plt.baselib.strings.isString;
 var isSymbol = plt.baselib.symbols.isSymbol;
@@ -1029,6 +1030,22 @@ EXPORTS['color-list->image'] =
                                     pinholeY);
         });
 
+EXPORTS['color-list->bitmap'] = 
+    makePrimitiveProcedure(
+        'color-list->image',
+        3,
+        function(MACHINE) {
+            var listOfColors = checkListofColor(MACHINE, 'color-list->image', 0);
+	    var width = checkNatural(MACHINE, 'color-list->image', 1);
+	    var height = checkNatural(MACHINE, 'color-list->image', 2);
+            return colorListToImage(listOfColors,
+                                    width,
+                                    height,
+                                    0,
+                                    0);
+        });
+
+
 EXPORTS['image-width'] = 
     makePrimitiveProcedure(
         'image-width',
@@ -1057,7 +1074,11 @@ EXPORTS['image-baseline'] =
         });
 
 
-
-
-
-
+EXPORTS['name->color'] = 
+    makePrimitiveProcedure(
+        'name->color',
+        1,
+        function(MACHINE) {
+            var name = checkSymbolOrString(MACHINE, 'name->color', 0);
+            return colorDb.get('' + name) || false;
+        });

image/private/main.rkt

@@ -54,6 +54,7 @@
                     rhombus
                     image->color-list
                     color-list->image
+                    color-list->bitmap
                     image-width
                     image-height
                     image-baseline
@@ -64,4 +65,7 @@
                     angle?
                     side-count?
                     step-count?
-                    image?))
+                    image?
+
+                    name->color
+                    ))

image/private/racket-impl.rkt

@@ -60,9 +60,17 @@
          ;; step-count?
 
          bitmap/url
+
+         name->color
          )
 
 
+(provide (rename-out (my-color-list->bitmap color-list->bitmap)))
+
+(define (my-color-list->bitmap x w h)
+  (color-list->bitmap x w h))
+(set! my-color-list->bitmap my-color-list->bitmap)
+
 
 (define-syntax (define-stubs stx)
   (syntax-case stx ()
@@ -76,6 +84,7 @@
 (define-stubs color-list->image)
 
 
+
   
 
 (define (my-step-count? x)
@@ -83,14 +92,14 @@
        (>= x 1)))
 
 
-(define (png-bytes->image bytes)
-  (error 'png-bytes->image "not implemented yet"))
-
-
 (define image-url (procedure-rename bitmap/url 'image-url))
 (define open-image-url (procedure-rename bitmap/url 'open-image-url))
 
 
+(define (name->color n)
+  (error 'name->color "not implemented yet"))
+
+
 (provide (rename-out [my-step-count? step-count?]
                      [bitmap/url image-url]
                      [bitmap/url open-image-url]))

tests/clipart-test/clipart.rkt

@@ -0,0 +1,146 @@
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/image)
+         (planet dyoo/whalesong/resource))
+
+
+;; color-near? : Color Color Number -> Boolean
+;; Is the first color within tolerance of the second?
+(define (color-near? a b tolerance)
+  (and (< (abs (- (color-red   a) (color-red   b))) tolerance)
+       (< (abs (- (color-green a) (color-green b))) tolerance)
+       (< (abs (- (color-blue  a) (color-blue  b))) tolerance)
+       (< (abs (- (color-alpha a) (color-alpha b))) tolerance)))
+
+;; color=? : Color Color -> Boolean
+;; Is the first color the same as the second?
+(define (color=? a b)
+  (and a b 
+       (equal? (color-red   a) (color-red   b))
+       (equal? (color-green a) (color-green b))
+       (equal? (color-blue  a) (color-blue  b))
+       (equal? (color-alpha a) (color-alpha b))))
+
+(define (imgvec-location x y w h)
+  (+ (* y w) x))
+
+(define (imgvec-adjacent-points imgvec loc width height)
+  (let ((x (remainder loc width))
+        (y (floor (/ loc width)))
+        (vloc (lambda (x y) (imgvec-location x y width height))))
+    (append
+     (if (< 0 x)            (list (vloc (- x 1)    y   )) '())
+     (if (< 0 y)            (list (vloc    x    (- y 1))) '())
+     (if (< x (- width 1))  (list (vloc (+ x 1)    y   )) '())
+     (if (< y (- height 1)) (list (vloc    x    (+ y 1))) '()))))
+
+(define (color-connected-points! imgvec width height start-color destination-color tolerance it)
+  (let ((mycol (vector-ref imgvec it)))
+    (when (and (not (color=? mycol destination-color))
+               (color-near? mycol start-color tolerance))
+      (begin
+        (vector-set! imgvec it destination-color)
+        (for-each (lambda (loc) 
+                    (color-connected-points! 
+                     imgvec width height start-color destination-color tolerance loc))
+                  (imgvec-adjacent-points imgvec it width height))))))
+
+(define (fill-from-point! img start-x start-y source-color destination-color tolerance dust-size)
+  (let* ((v (list->vector (image->color-list img)))
+         (width (image-width img))
+         (height (image-height img))
+         (c (if source-color
+                (name->color source-color)
+                (vector-ref v (imgvec-location start-x start-y width height))))
+         (d (if (string? destination-color) (name->color destination-color) destination-color)))
+    (begin
+      (when (not (color=? c d))
+        (color-connected-points! v width height c d tolerance
+                                 (imgvec-location start-x start-y width height)))
+      (color-list->bitmap (vector->list v) width height))))
+
+(define (transparent-from-corner img tolerance)
+  (fill-from-point! img 0 0 #f (make-color 0 0 0 0) tolerance 0))
+
+(define (transparent-from-corners img tolerance)
+  (let ((xprt (make-color 0 0 0 0))
+        (start-color #f)
+        (jaggies 0)
+        (w-1 (- (image-width img) 1))
+        (h-1 (- (image-height img) 1)))
+    (fill-from-point!
+     (fill-from-point!
+      (fill-from-point!
+       (fill-from-point! img 0 0 start-color xprt tolerance jaggies)
+       w-1 0 start-color xprt tolerance jaggies)
+      0 h-1 start-color xprt tolerance jaggies)
+     w-1 h-1 start-color xprt tolerance jaggies)))
+
+;; replace-color : Image Color Color Number -> Image
+;; In the given image, replace the source color (with the given tolerance)
+;; by the destination color
+(define (replace-color img source-color destination-color tolerance)
+  (let ((src (name->color source-color))
+        (dst (name->color destination-color)))
+    (color-list->bitmap
+     (map (lambda (c)
+            (if (color-near? c src tolerance)
+                dst
+                c))
+          (image->color-list img))
+     (image-width img)
+     (image-height img))))
+
+;; color->alpha : Image Color Number -> Image
+;; in the given image, transform the given color to transparency.
+(define (color->alpha img target-color tolerance)
+  (replace-color img target-color (make-color 0 0 0 0) tolerance))
+
+;; clipart-url : String -> Image
+;; try to grab the provided url and turn it into an image assuming a solid white background
+(define (clipart/url url)
+  (transparent-from-corners (bitmap/url url) 30))
+
+(define (time name thunk)
+  (let* ((start (current-seconds))
+         (result (thunk))
+         (elapsed (- (current-seconds) start)))
+    (begin
+      (display "Ran ") (display name) (display " in ") (display elapsed) (display " seconds.") (newline)
+      result)))
+
+(define BG (rectangle 300 100 "solid" "green"))
+(define-resource dog.jpg)   ;;  "http://t3.gstatic.com/images?q=tbn:ANd9GcSiCx-eVMoU6wpH2WgfNzOTd_wZunA-S07ZZJsGtHiKNfOUp2chMKmvEVajtg")
+(define DOG (scale 1/2 dog.jpg))
+                                        ;(define XDOG (time "(transparent-from-corners DOG 30)" (lambda () (transparent-from-corners DOG 30))))
+                                        ;(define D (overlay XDOG BG))
+                                        ;(define CDOG (overlay (clipart/url DOGURL) BG))
+                                        ;D
+
+(define (repeat num thunk)
+  (if (equal? num 0)
+      (thunk)
+      (begin
+        (thunk)
+        (repeat (- num 1) thunk))))
+(time "(transparent-from-corners DOG 30)" (lambda () (transparent-from-corners DOG 30)))
+;; Ran (transparent-from-corners DOG 30) in 7 (sometimes 8) seconds.
+(define v (time "just list->vector image->color-list" (lambda () (list->vector (image->color-list DOG)))))
+;; Ran just list->vector image->color-list in 0 seconds.
+(define DOG-many (vector-length v))
+(time (string-append (number->string DOG-many) " imgvec-adjacent-points")
+      (lambda () (repeat DOG-many (lambda () (imgvec-adjacent-points v (imgvec-location 41 41 45 45) 45 45)))))
+;; Ran 3136 imgvec-adjacent-points in 3 seconds.
+(time (string-append (number->string (* 4 DOG-many)) " imgvec-locations")
+      (lambda () (repeat (* 4 DOG-many) (lambda () (imgvec-location 41 41 45 45)))))
+;; Ran 3136 imgvec-locations in 1 seconds.
+(time (string-append (number->string (* 4 DOG-many)) " additions")
+      (lambda () (repeat (* 4 DOG-many) (lambda () (+ 4 5)))))
+(time (string-append (number->string (* 4 DOG-many)) " multiplies")
+      (lambda () (repeat (* 4 DOG-many) (lambda () (* 4 5)))))
+(time (string-append (number->string (* 4 DOG-many)) " function calls")
+      (lambda () (repeat (* 4 DOG-many) (lambda () #t))))
+;; Ran 3136 function calls in 0 seconds.
+
+;; at least 2 out of 10 seconds are being spent only on adding and multiplying?
+;; but that means that 3 seconds are being used in function calls, and I can just inline those... painful, but perhaps effective.
+