diff --git a/image/private/js-impl.js b/image/private/js-impl.js index 48eefac..b3bdcf3 100644 --- a/image/private/js-impl.js +++ b/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; + }); \ No newline at end of file diff --git a/image/private/main.rkt b/image/private/main.rkt index 18e168f..6ccc5f8 100644 --- a/image/private/main.rkt +++ b/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 + )) diff --git a/image/private/racket-impl.rkt b/image/private/racket-impl.rkt index 825a0c2..eb80c33 100644 --- a/image/private/racket-impl.rkt +++ b/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])) \ No newline at end of file diff --git a/tests/clipart-test/clipart.rkt b/tests/clipart-test/clipart.rkt new file mode 100644 index 0000000..c677d37 --- /dev/null +++ b/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. + diff --git a/tests/clipart-test/dog.jpg b/tests/clipart-test/dog.jpg new file mode 100644 index 0000000..b6f580b Binary files /dev/null and b/tests/clipart-test/dog.jpg differ