You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
408 lines
12 KiB
Scheme
408 lines
12 KiB
Scheme
(define num-colors 200)
|
|
(define mesh-color (make-object wx:colour% 50 155 50))
|
|
(define mesh-pen (make-object wx:pen% mesh-color 1 wx:const-solid))
|
|
|
|
(define black-pen (make-object wx:pen% "BLACK" 1 wx:const-solid))
|
|
|
|
(define colors
|
|
(tabulate num-colors
|
|
(lambda (i)
|
|
(make-object wx:colour%
|
|
(* 255 (expt (/ i (1- num-colors)) 1/2))
|
|
(* 255 (/ i (1- num-colors)))
|
|
(* 255 (expt (/ i (1- num-colors)) 1/2))))))
|
|
|
|
(define mesh%
|
|
(make-class mred:menu-frame%
|
|
(rename [super-make-menu-bar make-menu-bar]
|
|
; [super-on-paint on-paint]
|
|
)
|
|
(inherit make-menu show panel)
|
|
(public
|
|
[mesh #f]
|
|
|
|
[filename #f]
|
|
[margin 10]
|
|
|
|
[on-paint
|
|
(lambda ()
|
|
(send left-canvas on-paint)
|
|
(send right-canvas on-paint))]
|
|
|
|
[canvas%
|
|
(make-class mred:canvas%
|
|
(inherit set-background get-dc clear get-client-size)
|
|
(rename [super-on-event on-event])
|
|
(private
|
|
[w-brush (make-object wx:brush% "white" wx:const-solid)])
|
|
(public
|
|
[node-value-get (void)]
|
|
[node-value-update (void)]
|
|
[memory-dc (make-object wx:memory-dc%)]
|
|
[set-memory-dc! (lambda (mdc) (set! memory-dc mdc))]
|
|
[draw-line (void)]
|
|
[dc (void)]
|
|
[on-event
|
|
(let* ([dragging-node (void)]
|
|
[connections null]
|
|
[orig-x (void)]
|
|
[orig-y (void)]
|
|
[last-x -1]
|
|
[last-y -1]
|
|
[lines (lambda ()
|
|
(for-each
|
|
(lambda (x)
|
|
(let ([p (node-value-get (graph:value x))])
|
|
(draw-line (posn-x p) (posn-y p)
|
|
last-x last-y)))
|
|
connections))])
|
|
(lambda (event)
|
|
(cond
|
|
[(send event dragging?)
|
|
(let ([x (send event get-x)]
|
|
[y (send event get-y)])
|
|
(when (and (not (and (= x last-x)
|
|
(= x last-y)))
|
|
'(inside-triangles dragging-node x y))
|
|
(lines)
|
|
(set! last-x x)
|
|
(set! last-y y)
|
|
(lines)))]
|
|
[(send event button-down?)
|
|
(let ([x (send event get-x)]
|
|
[y (send event get-y)])
|
|
(send dc set-logical-function wx:const-xor)
|
|
(when mesh
|
|
(set! dragging-node (find-closest mesh x y node-value-get))
|
|
(set! connections (graph:connections dragging-node)))
|
|
(set! last-x x)
|
|
(set! last-y y)
|
|
(set! orig-x x)
|
|
(set! orig-y y)
|
|
(lines))]
|
|
[(send event button-up?)
|
|
(lines)
|
|
(send dc set-logical-function wx:const-copy)
|
|
(unless (void? dragging-node)
|
|
(node-value-update (graph:value dragging-node)
|
|
(make-posn last-x last-y)))
|
|
(let* ([posns (cons (make-posn last-x last-y)
|
|
(map (lambda (x)
|
|
(node-value-get (graph:value x)))
|
|
connections))]
|
|
[box-width (box 0)]
|
|
[box-height (box 0)]
|
|
[min-x orig-x]
|
|
[min-y orig-y]
|
|
[max-x orig-x]
|
|
[max-y orig-y])
|
|
(for-each (lambda (p)
|
|
(let ([x (posn-x p)]
|
|
[y (posn-y p)])
|
|
(when (< max-x x) (set! max-x x))
|
|
(when (< max-y y) (set! max-y y))
|
|
(when (< x min-x) (set! min-x x))
|
|
(when (< y min-y) (set! min-y y))))
|
|
posns)
|
|
'(send dc set-clipping-region min-x min-y
|
|
(1+ (- max-x min-x))
|
|
(1+ (- max-y min-y)))
|
|
(on-paint)
|
|
(get-client-size box-width box-height)
|
|
(send dc set-clipping-region
|
|
0 0 (unbox box-width) (unbox box-height)))
|
|
(set! dragging-node (void))
|
|
(set! connections (void))
|
|
(set! orig-x (void))
|
|
(set! orig-y (void))
|
|
(set! last-x (void))
|
|
(set! last-y (void))]
|
|
[else (super-on-event event)])))]
|
|
[on-paint
|
|
(lambda ()
|
|
(let* ([get-points
|
|
(lambda (node)
|
|
(let* ([value (graph:value node)]
|
|
[p (node-value-get value)])
|
|
(values (posn-x p)(posn-y p))))]
|
|
[traverse
|
|
(lambda (node)
|
|
(let-values ([(b-x b-y) (get-points node)])
|
|
(let* ([children (graph:children node)]
|
|
[chili
|
|
(lambda (child)
|
|
(let-values ([(e-x e-y) (get-points child)])
|
|
(draw-line b-x b-y e-x e-y)))])
|
|
(for-each chili children))))]
|
|
[dc (get-dc)]
|
|
[by (box 0)]
|
|
[bx (box 0)])
|
|
(get-client-size bx by)
|
|
(set-background w-brush)
|
|
(clear)
|
|
(send dc set-pen black-pen)
|
|
(send dc blit 0 0 (unbox bx) (unbox by)
|
|
memory-dc 0 0 wx:const-copy)
|
|
(when mesh
|
|
(send dc set-pen mesh-pen)
|
|
'(send dc set-logical-function wx:const-xor)
|
|
(graph:traverse mesh traverse)
|
|
'(send dc set-logical-function wx:const-copy))))])
|
|
(lambda (get update . args)
|
|
(apply super-init args)
|
|
(set! dc (get-dc))
|
|
(set! draw-line (ivar dc draw-line))
|
|
(set! node-value-get get)
|
|
(set! node-value-update update)))]
|
|
|
|
[left-filename #f]
|
|
[right-filename #f]
|
|
[left-2dvec #f]
|
|
[right-2dvec #f]
|
|
[left-canvas #f]
|
|
[right-canvas #f]
|
|
[default-size 200]
|
|
|
|
[canvas-size-diff 0]
|
|
|
|
[get-sizes
|
|
(lambda ()
|
|
(let* ([left-width (if left-2dvec
|
|
(ivar left-2dvec width)
|
|
default-size)]
|
|
[left-height (if left-2dvec
|
|
(ivar left-2dvec height)
|
|
default-size)]
|
|
[right-width (if right-2dvec
|
|
(ivar right-2dvec width)
|
|
default-size)]
|
|
[right-height (if right-2dvec
|
|
(ivar right-2dvec height)
|
|
default-size)])
|
|
(values left-width left-height right-width right-height)))]
|
|
[resize-panels
|
|
(lambda ()
|
|
(let-values ([(left-width left-height right-width right-height)
|
|
(get-sizes)])
|
|
(send left-canvas user-min-width (+ canvas-size-diff left-width))
|
|
(send left-canvas user-min-height (+ canvas-size-diff left-height))
|
|
(send right-canvas user-min-width (+ canvas-size-diff right-width))
|
|
(send right-canvas user-min-height (+ canvas-size-diff right-height))))]
|
|
[open
|
|
(lambda (fn)
|
|
(mred:show-busy-cursor
|
|
(lambda ()
|
|
(let* ([port (open-input-file fn)]
|
|
[local-mesh #f]
|
|
[read-value
|
|
(lambda (port)
|
|
(let ([left (read port)]
|
|
[right (read port)])
|
|
(cons (apply make-posn left)
|
|
(apply make-posn right))))])
|
|
(set! left-filename (read port))
|
|
(set! right-filename (read port))
|
|
(when (read port)
|
|
(set! local-mesh (graph:read read-value port)))
|
|
(close-input-port port)
|
|
(debug-print mesh% 'read 'file)
|
|
(set! left-2dvec (build-image left-filename))
|
|
(set! right-2dvec (build-image right-filename))
|
|
(debug-print mesh% 'built-2dvecs)
|
|
(send left-canvas set-memory-dc! (build-memory-dc left-2dvec))
|
|
(send right-canvas set-memory-dc! (build-memory-dc right-2dvec))
|
|
(debug-print mesh% 'updated 'canvases)
|
|
(set! mesh local-mesh)
|
|
(set! filename fn)
|
|
(resize-panels)
|
|
(on-paint)))))]
|
|
[save
|
|
(lambda ()
|
|
(if filename
|
|
(begin
|
|
(let ([port (open-output-file filename 'replace)]
|
|
[print-value
|
|
(lambda (port v)
|
|
(let ([left (car v)]
|
|
[right (cdr v)])
|
|
(fprintf port "~s ~s"
|
|
(list (posn-x left) (posn-y left))
|
|
(list (posn-x right) (posn-y right)))))])
|
|
(fprintf port ";;; data req'd to setup a morph~n~n")
|
|
(fprintf port "~s ; source filename~n" left-filename)
|
|
(fprintf port "~s ; destination filename~n" right-filename)
|
|
(fprintf port "~n;; mesh~n")
|
|
(if mesh
|
|
(begin
|
|
(fprintf port "#t ; mesh is setup~n")
|
|
(graph:fprintf port mesh print-value))
|
|
(fprintf port "#f ; mesh is not setup~n"))
|
|
(close-output-port port)))
|
|
(save-as)))]
|
|
[save-as
|
|
(lambda ()
|
|
(let ([fn (mred:common-put-file)])
|
|
(when fn
|
|
(set! filename fn)
|
|
(save))))]
|
|
|
|
[make-menu-bar
|
|
(lambda ()
|
|
(let ([bar (super-make-menu-bar)]
|
|
[file-menu (make-menu)]
|
|
[picture-menu (make-menu)]
|
|
[mesh-menu (make-menu)]
|
|
[morph-menu (make-menu)])
|
|
(send file-menu append-item "Open..."
|
|
(lambda ()
|
|
(let ([fn (mred:common-get-file)])
|
|
(when fn (open fn)))))
|
|
(send file-menu append-item "Save..." save)
|
|
(send file-menu append-item "Save As..." save-as)
|
|
(send file-menu append-separator)
|
|
(send file-menu append-item "Close" (lambda () (show #f)))
|
|
(send picture-menu append-item "Select Source Image..."
|
|
(lambda ()
|
|
(let ([fn (mred:common-get-file
|
|
'() "Please choose an image.")])
|
|
(when fn
|
|
(mred:show-busy-cursor
|
|
(lambda ()
|
|
(set! left-filename fn)
|
|
(time (set! left-2dvec (build-image fn)))
|
|
(time (send left-canvas set-memory-dc!
|
|
(build-memory-dc left-2dvec)))
|
|
(set! mesh #f)
|
|
(resize-panels)
|
|
(on-paint)))))))
|
|
(send picture-menu append-item "Select Destination Image..."
|
|
(lambda ()
|
|
(let ([fn (mred:common-get-file
|
|
'() "Please choose an image.")])
|
|
(when fn
|
|
(mred:show-busy-cursor
|
|
(lambda ()
|
|
(set! right-filename fn)
|
|
(set! right-2dvec (build-image fn))
|
|
(send right-canvas set-memory-dc!
|
|
(build-memory-dc right-2dvec))
|
|
(set! mesh #f)
|
|
(resize-panels)
|
|
(on-paint)))))))
|
|
(send picture-menu append-item "Exchange Images"
|
|
(lambda ()
|
|
(let ([left-mdc (ivar left-canvas memory-dc)]
|
|
[right-mdc (ivar right-canvas memory-dc)]
|
|
[tmp left-2dvec]
|
|
[exchange
|
|
(lambda (node)
|
|
(let* ([value (graph:value node)]
|
|
[left (car value)])
|
|
(set-car! value (cdr value))
|
|
(set-cdr! value left)))])
|
|
(set! left-2dvec right-2dvec)
|
|
(set! right-2dvec tmp)
|
|
(send right-canvas set-memory-dc! left-mdc)
|
|
(send left-canvas set-memory-dc! right-mdc)
|
|
(graph:traverse mesh exchange)
|
|
(resize-panels)
|
|
(on-paint))))
|
|
(send mesh-menu append-item "Fresh Mesh..."
|
|
(lambda ()
|
|
(fresh-mesh (get-number-from-user
|
|
"How large should the mesh be?"
|
|
"Mesh Size" "5"))
|
|
(on-paint)))
|
|
(send morph-menu append-item "Morph..."
|
|
(lambda () (morph (get-number-from-user
|
|
"How many steps in the morph?"
|
|
"Morph Size" "3"))))
|
|
(send bar append file-menu "File")
|
|
(send bar append picture-menu "Images")
|
|
(send bar append mesh-menu "Mesh")
|
|
(send bar append morph-menu "Morph")
|
|
bar))]
|
|
[morph
|
|
(lambda (steps)
|
|
(if (and left-2dvec right-2dvec mesh)
|
|
(main mesh (ivar left-canvas memory-dc)
|
|
(ivar right-canvas memory-dc)
|
|
left-2dvec right-2dvec steps)
|
|
(wx:message-box "Please choose images and mesh.")))]
|
|
[fresh-mesh
|
|
(lambda (n)
|
|
(let-values ([(left-width left-height right-width right-height)
|
|
(get-sizes)])
|
|
(let* ([nodes
|
|
(let loop ([row (1- n)] [column (1- n)])
|
|
(let ([row-percent (/ row (1- n))]
|
|
[column-percent (/ column (1- n))])
|
|
(cons
|
|
(graph:node
|
|
(cons (make-posn (* left-width row-percent)
|
|
(* left-height column-percent))
|
|
(make-posn (* right-width row-percent)
|
|
(* right-height column-percent))))
|
|
(cond
|
|
[(and (= row 0) (= column 0)) null]
|
|
[(= row 0) (loop (1- n) (1- column))]
|
|
[else (loop (1- row) column)]))))]
|
|
[2dvec (make-object 2d-vector% n n 0)]
|
|
[lookup (ivar 2dvec lookup)]
|
|
[update (ivar 2dvec update)])
|
|
(send 2dvec bend (reverse nodes))
|
|
|
|
(if (< 2 n)
|
|
(begin
|
|
'(graph:edge (lookup 0 (1- n)) (lookup 1 (1- n)))
|
|
(let loop ([x (- n 2)] [y (- n 2)])
|
|
(graph:edge (lookup x y) (lookup x (1+ y)))
|
|
(graph:edge (lookup x y) (lookup (1+ x) y))
|
|
(graph:edge (lookup x y) (lookup (1+ x) (1+ y)))
|
|
(cond [(and (= x 0) (= y 0)) (void)]
|
|
[(= x 0) (loop (- n 2) (1- y))]
|
|
[else (loop (1- x) y)]))
|
|
(let loop ([i (- n 2)])
|
|
(when (<= 0 i)
|
|
(graph:edge (lookup (1- n) i) (lookup (1- n) (1+ i)))
|
|
(graph:edge (lookup i (1- n)) (lookup (1+ i) (1- n)))
|
|
(loop (1- i)))))
|
|
(begin
|
|
(graph:edge (lookup 0 0) (lookup 0 1))
|
|
(graph:edge (lookup 0 0) (lookup 1 0))
|
|
(graph:edge (lookup 0 0) (lookup 1 1))
|
|
(graph:edge (lookup 1 0) (lookup 1 1))
|
|
(graph:edge (lookup 0 1) (lookup 1 1))))
|
|
|
|
(set! mesh (lookup 0 0)))))])
|
|
|
|
(lambda ()
|
|
(super-init '() "Mesh Construction")
|
|
(send panel stretchable-in-x #f)
|
|
(send panel stretchable-in-y #f)
|
|
(let ([p (make-object mred:horizontal-panel% panel)]
|
|
[init
|
|
(lambda (c)
|
|
(send c user-min-height default-size)
|
|
(send c user-min-width default-size)
|
|
(send c stretchable-in-x #f)
|
|
(send c stretchable-in-y #f))])
|
|
(send p stretchable-in-x #f)
|
|
(send p stretchable-in-y #f)
|
|
(set! left-canvas (make-object canvas% car set-car! p))
|
|
(init left-canvas)
|
|
(set! right-canvas (make-object canvas% cdr set-cdr! p))
|
|
(init right-canvas))
|
|
(let ([w (box 0)]
|
|
[h (box 0)])
|
|
(send right-canvas get-client-size w h)
|
|
(set! canvas-size-diff (- (send right-canvas get-width) (unbox w))))
|
|
(show #t))))
|
|
|
|
(define mesh
|
|
(begin (when (defined? 'mesh)
|
|
(send mesh show #f))
|
|
(make-object mesh%)))
|
|
'(send mesh open "/home/robby/class/graphics/lab5/test/rd.morph")
|
|
'(send mesh morph 3)
|