;;; ;;; primosaic.scm ;;; ;;; Unlike the PS1 mosaics, primosaics avoid using the same tile repeatedly. ;;; They are not supremosaics, though --- we use a greedy algorithm to approximate ;;; the NP-complete supremosaic problem quickly. ;;; ;;; UVA CS200 Spring 2002 ;;; Problem Set 5 ;;; (require-library "file.ss") ;;; We use the file library for filename-extension (require-library "trace.ss") ;;; useful for debugging ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; This code is unchanged from PS1. ;;; ;;; But, you should look through it again now --- it should make a lot more sense ;;; to you now then it did when you did PS1. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Pathname Constants ;;; ;;; If you extract the images to a different place, you will need to change this: (define path-name "K:/cs200/ps5/") ;;; URL Prefix for where the tile images are: (define tile-prefix "http://www.cs.virginia.edu/cs200/problem-sets/ps5/uvaimages/small/") ;;; URL Prefix for where the link (big) images are: (define link-prefix "http://www.cs.virginia.edu/cs200/problem-sets/ps5/uvaimages/") ;;; This gives a rough bound on the number of samples taken for each tile image. ;;; A higher number improves the quality of the sampling, but increases the ;;; evaluation time. ;;; ;;; Around 20 seems to be plenty. For slow machines, try lowering this. (define num-samples 20) ;;; ;;; Loading tile images ;;; ;;; get-one-image filename - load a compressed image file into a bitmap (define (get-one-image filename) (make-object bitmap% filename)) ;;; is-image? filename - evaluates to true if filename is the name of an image type file (define (is-image? filename) (let ((ext (filename-extension filename))) (or (equal? ext "jpg") (equal? ext "JPG") (equal? ext "gif") (equal? ext "GIF") (equal? ext "bmp") (equal? ext "BMP")))) ;;; get-image-names directory - evaluates to a list of (filename bitmap) lists for each ;;; filename in directory that is an image. (define (get-image-names directory) (begin (current-directory directory) ;;; enter the images directory ;; filter applies a function to every element of a list and evaluates ;; to a list containing only thoses elements of the original list ;; for which the function applied to the element evaluates to true (#t). ;; So, this produces a list of all files in the directory for which ;; is-image? is true. (filter is-image? (directory-list)))) ;;; ;;; load-bitmaps image-names ;;; (define (load-bitmaps image-names) (map get-one-image image-names)) ;;; ;;; Displaying images (by creating a web page) ;;; ;;; ;;; Creates an open file for displaying tiles ;;; (define (produce-tiles-page output-filename image-list tile-width tile-height) (call-with-output-file output-filename (lambda (output-file) (printf "Creating photomosaic in ~a...~n" output-filename) (display-tiles-page output-file image-list tile-width tile-height)))) ;;; ;;; display-tiles takes: ;;; output-file - output file ;;; tiles - the tiles for the mosaic (a list of image filenames for each row) ;;; tile-width - display width of each tile ;;; tile-height - display height of each tile ;;; (define (display-tiles-page output-file tiles tile-width tile-height) ;;; Print out some html formatting commands (print-page-header output-file) ;;; Print out the tiles (display-tiles output-file tiles tile-width tile-height) ;;; Print out some html formatting commands and close the output file. (print-page-footer output-file) ) (define (display-tiles output-file tiles tile-width tile-height) (map ;;; We use lambda to make a procedure using this row. That procedure ;;; applies display-one-row to this row and the other parameters. (lambda (row) (display-one-row output-file row tile-width tile-height)) tiles ) ) ;;; HTML formating (define (print-page-header fout) (fprintf fout "CS200osaic~n") (fprintf fout "~n") (fprintf fout "


") (fprintf fout "")) (define (print-page-footer fout) (fprintf fout "
~n") (fprintf fout "~n")) ;;; ;;; display-one-row ;;; (define (display-one-row output-file row tile-width tile-height) (fprintf output-file "~n") (map (lambda (tile) (display-one-tile output-file tile tile-width tile-height)) row) (fprintf output-file "~n") ) ; end display-one-row ;;; ;;; display-one-tile ;;; (define (display-one-tile output-file tile-name tile-width tile-height) (fprintf output-file "~n") (fprintf output-file "~n" link-prefix tile-name tile-prefix tile-name tile-width tile-height) ) ; end display-one-tile ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; Calculating average colors of bitmaps ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (calculate-average-colors image-list) (map-safe average-color image-list)) ;;; ;;; Generate pixel points to sample an area ;;; (define (generate-sample-points startx starty width height num-points) ;;; Generate list (((x0 y0) (x1 y0) ... (xn y0)) ;;; ((x0 y1) ... )) ;;; ... ;;; (((x_0 y_m)) ... (x_n y_m))) ;;; of points to sample in a region from (startx, starty) to ;;; (startx + width, starty + height). ;;; num-points is a rough guide to the number of points to sample, but ;;; generate-sample-points may return more or fewer. (let* ((spacing (max 1 (/ width (sqrt num-points)))) ;;; can't be less than 1 (height-spacing (max 1 (/ (* spacing height) width)))) (generate-sample-points-worker startx starty startx starty width height spacing spacing '()))) (define (generate-sample-points-worker startx starty ;;; Where we started curx cury ;;; Where we are now width height ;;; Area to sample xspacing yspacing ;;; Space between samples points) ;;; List of sample points so far (if (>= (round cury) (+ height starty)) points ;;; done (if (>= (round curx) (+ width startx)) ;;; move down to the next row (cons points (generate-sample-points-worker startx starty startx (+ cury yspacing) width height xspacing yspacing '())) ;;; else, add the current point to the list, and move right (generate-sample-points-worker startx starty (+ curx xspacing) cury width height xspacing yspacing (append points (list (make-point (round curx) (round cury)))))))) ;;; ;;; average-colors takes a list of colors, and evaluates to the "average" color ;;; (define (sum-colors color-list) (if (null? color-list) (make-color 0 0 0) (add-color (first color-list) (sum-colors (rest color-list))))) (define (add-color color1 color2) (make-color (+ (get-red color1) (get-red color2)) (+ (get-green color1) (get-green color2)) (+ (get-blue color1) (get-blue color2)))) (define (average-colors point-colors) (let ((num-colors (length point-colors)) (sum-color (sum-colors point-colors))) (make-color (/ (get-red sum-color) num-colors) (/ (get-green sum-color) num-colors) (/ (get-blue sum-color) num-colors)))) (define (average-color bmimage) (let ((width (send bmimage get-width)) (height (send bmimage get-height)) (bmp (make-object bitmap-dc%))) ;;; don't have get-pixel for bitmap%, need a dc (send bmp set-bitmap bmimage) (let ((result (average-color-region bmp (make-point 0 0) (make-point (- width 1) (- height 1)) num-samples))) (send bmp clear) ;;; Release the bitmap result) ) ) (define (average-color-region bmdc startcorner size num-samples) (let ((color (make-object color% 0 0 0))) ;;; need a color object to get the pixel color (average-colors (flatten (map2d (lambda (point) (send bmdc get-pixel (get-x point) (get-y point) color) (assert (> (get-image-width bmdc) (get-x point))) (assert (> (get-image-height bmdc) (get-y point))) (make-color (send color red) (send color green) (send color blue))) (generate-sample-points (get-x startcorner) (get-y startcorner) (get-x size) (get-y size) num-samples) ) ) ) ) ) ;;; ;;; Determining the images to draw ;;; (define (generate-regions master-width master-height sample-width sample-height) (generate-sample-points-worker 0 0 0 0 (- master-width sample-width) (- master-height sample-height) sample-width sample-height '())) (define (choose-tiles master-bitmap tiles sample-width sample-height tile-comparator) ;;; ;;; We need to last the master image as a bitmap in a device context ;;; to be able to sample points from it. ;;; (let ((master-dc (make-object bitmap-dc%))) (send master-dc set-bitmap master-bitmap) (let* ((master-width (get-image-width master-dc)) (master-height (get-image-height master-dc)) (sample-size (make-point sample-width sample-height)) (samples (map2d (lambda (point) ;;; for each region, we need the average color (average-color-region master-dc point sample-size num-samples)) (generate-regions master-width master-height sample-width sample-height)))) (select-mosaic-tiles samples tiles tile-comparator)))) ;;; ;;; Creates a photomosaic for image master-image using the images in tiles-directory as tiles. ;;; The tile-comparator function is a function taking three colors, master, tile1 and tile2, ;;; and returning #t if tile1 is a better color match for master and #f otherwise. ;;; (define (find-best-match sample remaining-tiles tile-comparator) (if (null? remaining-tiles) #f (pick-better-match sample (first remaining-tiles) (find-best-match sample (rest remaining-tiles) tile-comparator) tile-comparator))) (define (pick-better-match sample tile1 tile2 tile-comparator) (if (not tile2) tile1 (if (not tile1) tile2 ;;; tile-comparator returns true if the first one is better (if (tile-comparator sample tile1 tile2) tile1 tile2) ) ) ) (define (select-mosaic-tiles samples tiles tile-comparator) (map2d (lambda (sample) (let ((tile (find-best-match sample tiles tile-comparator))) (increment-tile-count tile) (tile-name tile))) samples) ) ;;; ;;; make-photomosaic ;;; (define (make-photomosaic master-image ;;; Filename for the "big" picture tiles-directory ;;; Directory containing the tile images tile-width tile-height ;;; Display width and height of the tiles (doesn't have to match actual size) sample-width sample-height ;;; Sample width and height (each tile covers this size area in master) output-filename ;;; Name of file to generate (.html) tile-comparator) ;;; Function for comparing colors (printf "Loading tiles...~n") (let ((tile-names (get-image-names tiles-directory))) (printf "Found ~a tiles.~n" (length tile-names)) (if (null? tile-names) ;;; If there we no images found in the tiles-directory, we quit. (printf "No tiles loaded. Cannot create photomosaic.") (begin (printf "Selecting photomosaic tiles...~n") (produce-tiles-page output-filename (choose-tiles (get-one-image master-image) (merge-lists (list tile-names (calculate-average-colors (load-bitmaps tile-names)))) sample-width sample-height tile-comparator) tile-width tile-height) (printf "Done.") ) ) ) ) (define (make-primosaic master-image ;;; Filename for the "big" picture tiles-directory ;;; Directory containing the tile images tile-width tile-height ;;; Display width and height of the tiles (doesn't have to match actual size) sample-width sample-height ;;; Sample width and height (each tile covers this size area in master) output-filename ;;; Name of file to generate (.html) tile-comparator) ;;; Function for comparing colors (printf "Loading tiles...~n") (let ((tile-names (get-image-names tiles-directory))) (printf "Found ~a tiles.~n" (length tile-names)) (if (null? tile-names) ;;; If there we no images found in the tiles-directory, we quit. (printf "No tiles loaded. Cannot create photomosaic.") (begin (printf "Selecting photomosaic tiles...~n") (produce-tiles-page output-filename (choose-tiles (get-one-image master-image) (merge-lists (list tile-names (calculate-average-colors (load-bitmaps tile-names)) (map (lambda (x) 0) tile-names))) sample-width sample-height tile-comparator) tile-width tile-height) (printf "Done.") ) ) ) ) (define diff-weighting (* 3 (* 50 50))) (define (tile-matcher sample tile1 tile2) (< (+ (color-difference sample (tile-color tile1)) (* diff-weighting (tile-count tile1))) (+ (color-difference sample (tile-color tile2)) (* diff-weighting (tile-count tile2))))) (define (square x) (* x x)) (define (color-difference c1 c2) (+ (square (- (get-red c1) (get-red c2))) (square (- (get-green c1) (get-green c2))) (square (- (get-blue c1) (get-blue c2))))) (define (make-rotundasaic output-filename) (make-primosaic (string-append path-name "rotunda.gif") (string-append path-name "uvaimages/small") 36 28 ;;; tile sizes 18 14 ;;; sample square sizes output-filename tile-matcher)) ;;; ;;; Data Abstraction methods ;;; (define (get-red col) (first col)) (define (get-green col) (second col)) (define (get-blue col) (third col)) (define (make-color r g b) (list r g b)) (define (valid-color? color) (and (list? color) (= (length color) 3) (>= (get-red color) 0) (<= (get-red color) 255) (>= (get-green color) 0) (<= (get-green color) 255) (>= (get-blue color) 0) (<= (get-blue color) 255))) (define (make-point x y) (list x y)) (define (get-x point) (first point)) (define (get-y point) (second point)) ;;; tiles are a list of (filename color count) (define (tile-name tile) (first tile)) (define (tile-color tile) (second tile)) (define (tile-count tile) (third tile)) (define (increment-tile-count tile) (set-car! (cdr (cdr tile)) (+ 1 (car (cdr (cdr tile)))))) ;;; Utility routines (define (flatten ll) (if (null? ll) '() (flat-append (car ll) (flatten (cdr ll))))) (define (flat-append lst ll) (if (null? lst) ll (cons (car lst) (flat-append (cdr lst) ll)))) (define (map-safe f l) (map f (check (lambda (l) (not (null? l))) l))) (define (map2d f ll) (map-safe (lambda (inner-list) (map f inner-list)) ll)) (define (get-image-height bmdc) (let-values (((width height) (send bmdc get-size))) height)) (define (get-image-width bmdc) (let-values (((width height) (send bmdc get-size))) width)) ;;; ;;; merge-lists takes a list of lists, and creates a new list of lists ;;; where the nth element of the result is a list of the nth elements ;;; of each list in its parameter. ;;; requires All the lists in lists must be the same length! ;;; (define (merge-lists lists) (if (null? (first lists)) '() (cons (map first lists) (merge-lists (map rest lists))))) (define (check pred pass) (if (pred pass) pass (error ~a "Check failed: "))) (define (assert pred) (if (not pred) (error "Assertion failed.~nOpps - this means there is probably a bug in Dave's code! Sorry!~nContact him or a TA for help.")))