display.rkt

#lang racket/base

(require racket/gui
         "utils.rkt"
         pict
         mrlib/switchable-button
         )

;0.02mm = 20um
(define pixel-resolution 0.02) 

(define my-frame (new frame%
                      [label "x"]))

(define my-canvas%
  (class canvas%
    
    (inherit get-dc)
    
    (field
     ;display selection box
     [display-select-box #f] 
     [display-select-picture #f] 
     [select-box '()]
     [image-select-box '()]
     [canvas-width 800]
     [canvas-height 600]
     [x-offset 0]
     [y-offset 0]
     
     ;canvas display variables
     [rotation 0]
     [transformation-matrix (vector 1 0 0 1 0 0)]
     [display-scale 1]
     [pixel-scale 1]

     ;image display variables
     [image-origin-x 0]
     [image-origin-y 0]
     [image-width 0]
     [image-height 0]
     [selected-img #f]
     [selected-img-width 0]
     [selected-img-height 0]
     
     ;interaction variables
     [init-cursor-x 0]
     [init-cursor-y 0]
     [cursor-x 0]
     [cursor-y 0]
     [scaled-cursor-x 0]
     [scaled-cursor-y 0]
     )
    
    (define-syntax change-cursor
      (lambda (stx)
        (syntax-case stx ()
          [(_ cursor-type)
           #'(send this set-cursor cursor-type)])))
    
    ;; CURSOR TYPES
    (define normal (make-object cursor% 'arrow))
    (define panning (make-object cursor% 'hand))
    (define selecting (make-object cursor% 'cross))
    
    ;; MOUSE SCALING
    ;scale mouse coordinates to display coordinates
    (define (mouse2pixel-x x)
      (let* ([offset-in-pixels (* x-offset pixel-scale)]
             [cursor-pos-in-pixels (* (- cursor-x x-offset) pixel-scale)])
        cursor-pos-in-pixels))
    (define (mouse2pixel-y y)
      (let* ([offset-in-pixels (* y-offset pixel-scale)]
             [cursor-pos-in-pixels (* (- cursor-y y-offset) pixel-scale)])
        cursor-pos-in-pixels))

    ;; 0,0 starts at the top corner, and x and y are positive rightwards and downwards respectively.
    (define/public (starting-coordinates)
      (let* ([left-edge-x (* -1 x-offset pixel-scale)]
             [top-edge-y (/ -1 y-offset pixel-scale)])
        (values left-edge-x top-edge-y)))
    
    (define (get-valid-x-offset x)
      (cond [(positive? x) (smallest (list x-offset 0))]
            [(> image-width (* (+ canvas-width (abs x)) pixel-scale)) x]
            [else (* -1 (/ (- image-width (* canvas-width pixel-scale)) pixel-scale))]))
    (define (get-valid-y-offset y)
      (cond [(positive? y) (smallest (list y-offset 0))]
            [(> image-height (* (+ canvas-height (abs y)) pixel-scale)) y]
            [else (* -1 (/ (- image-height (* canvas-height pixel-scale)) pixel-scale))]))
    
    (define (get-valid-display-scale x)
      (define max-display-scale (biggest (list (/ canvas-width image-width)
                                               (/ canvas-height image-height))))
      (if (> max-display-scale x) max-display-scale x))

    (define (zoom-in)
      (center #t))
    (define (zoom-out)
      (center #f))

    (define/public (show-full-image)
      (set! x-offset 0)
      (set! y-offset 0)
      (set! display-scale (get-valid-display-scale 0.000001)))
    
    ;; what this really does is adjust the new x-offset
    (define (center zoom-in?)
      (let* ([pixel-cursor-x (mouse2pixel-x cursor-x)]
             [pixel-cursor-y (mouse2pixel-y cursor-y)]
             ;we want to keep the pixel-cursor-x and pixel-cursor-y at cursor-x and cursor-y
             ;after we zoom out
             [new-scale (if zoom-in?
                              (+ display-scale 0.1)
                              (- display-scale 0.1))]
             [new-pixel-scale (/ 1 new-scale)]
             ;find out how much cursor-x and cursor-y deviates from the left and top edges in pixels.
             [pixel-x-to-adjust (* cursor-x new-pixel-scale)]
             [pixel-y-to-adjust (* cursor-y new-pixel-scale)]
             ;the new left and top edges 
             [pixel-new-left-edge (- pixel-cursor-x pixel-x-to-adjust)]
             [pixel-new-top-edge (- pixel-cursor-y pixel-y-to-adjust)]
             [absolute-new-left-edge (* -1 (/ pixel-new-left-edge new-pixel-scale))]
             [absolute-new-top-edge (* -1 (/ pixel-new-top-edge new-pixel-scale))])
        (set! display-scale (get-valid-display-scale new-scale))
        (set! pixel-scale (/ 1 display-scale))
        (set! x-offset (get-valid-x-offset absolute-new-left-edge))
        (set! y-offset (get-valid-y-offset absolute-new-top-edge))
        ))
    
    (define/public (update-canvas)
      (set! display-scale (get-valid-display-scale display-scale))
      (set! pixel-scale (/ 1 display-scale))
      (set! x-offset (get-valid-x-offset x-offset))
      (set! y-offset (get-valid-y-offset y-offset))
      (when (positive? x-offset) (display x-offset) (newline))
      (send (get-dc) set-transformation (vector transformation-matrix x-offset y-offset display-scale display-scale rotation))
      (send this refresh))
    
    (define/public (update-display-messages)
      (send cursor-x-display set-label (format "X: ~a" cursor-x))
      (send cursor-y-display set-label (format "Y: ~a" cursor-y))
      (send magnification-display set-label (format "Magnification: ~a" (round-2 pixel-scale)))
      (send pixel-x-display set-label (format "X: ~a" (round-3 (* pixel-resolution (mouse2pixel-x cursor-x)))))
      (send pixel-y-display set-label (format "Y: ~a" (round-3 (* pixel-resolution (mouse2pixel-y cursor-y)))))
      )
    
    ;; KEY EVENTS
    (define/override (on-char event)
      (let ((key (send event get-key-code)))
        (special-control-key #t)
        (cond [(equal? key 'wheel-up)
               (unless (= cursor-x 0) (zoom-in)
                 )]
              [(equal? key 'escape) 
               (set! display-select-picture #f)
               (set! selected-img #f)]
              [(equal? key 'wheel-down)
               (when (and (not (= cursor-x 0)) (> (- display-scale 0.1) 0))
                 (zoom-out)
                 )])
        (update-display-messages)
        (update-canvas)))
    
    ;; MOUSE EVENTS
    (define/override (on-event event)
      (define drawer (get-dc))
      
      (set! cursor-x (send event get-x))
      (set! cursor-y (send event get-y))
      (set! scaled-cursor-x (mouse2pixel-x cursor-x))
      (set! scaled-cursor-y (mouse2pixel-y cursor-y))
      (set! canvas-width (send this get-width))
      (set! canvas-height (send this get-height))
      
      (define-syntax-rule (is-key-event? query)
        (send event query))
      (define (is-mouse-event? query)
        (equal? query (send event get-event-type)))
      
      ;key and mouse combinations
      (define click-right  (is-mouse-event? 'right-down))
      (define click-left   (is-mouse-event? 'left-down))
      (define release-left (is-mouse-event? 'left-up))
      (define hold-ctrl    (is-key-event? get-control-down))
      (define caps-on      (is-key-event? get-caps-down))
      (define dragging     (send event dragging?)) ;click and hold
      
      (define start-panning? click-left)
      (define is-panning? (and dragging (number? init-cursor-x) (number? init-cursor-y)))
      (define end-panning? release-left) 
      (define start-selecting? (and click-left hold-ctrl))
      (define is-selecting? (and dragging hold-ctrl))
      (define end-selecting? (and release-left hold-ctrl))

      (update-display-messages)
      
      (cond
        (click-right
         (display (format "Cursor X in absolutes: ~a"  cursor-x)) (newline)
         (display (format "Cursor X in pixels: ~a"  (mouse2pixel-x cursor-x))) (newline)
         (display (format "-----------------------")) (newline)
         )
        (end-selecting?
         (change-cursor normal)
         (set! display-select-box #f)
         (set! display-select-picture #t)
         (let* ((lst select-box)
                (1st (first lst))
                (2nd (second lst))
                (3rd (third lst))
                (4th (fourth lst))
                (width  (round-to-int (abs (- (first 1st) (first 3rd)))))
                (height (round-to-int (abs (- (second 1st) (second 3rd))))))
           (cond [(within-picture? select-box)
                   (set! selected-img (make-bytes (* 4 width height)))
                   (set! selected-img-width width)
                   (set! selected-img-height height)
                   (time (send bm-dc get-argb-pixels
                               (round-to-int (smallest (list (first 1st) (first 3rd))))
                               (round-to-int (smallest (list (second 1st) (second 3rd))))
                               width
                               height
                               selected-img))]
                  [else 
                   (set! selected-img #f)
                   (set! selected-img-width #f)
                   (set! selected-img-height #f)]))
         (update-canvas))
        (end-panning?
         ;see conditions for is-panning? to understand setting init-cursor-x and init-cursor-y values
         (set! init-cursor-x #f)
         (set! init-cursor-y #f)
         (set! display-select-box #f)
         ;fix the offset so that the screen stays where it is after panning is finished
         (set! x-offset (get-valid-x-offset (vector-ref (send drawer get-transformation) 1)))
         (set! y-offset (get-valid-y-offset (vector-ref (send drawer get-transformation) 2)))
         (change-cursor normal))
        (start-selecting?
         (set! init-cursor-x scaled-cursor-x)
         (set! init-cursor-y scaled-cursor-y)
         (set! display-select-box #t))
        (start-panning?
         (set! init-cursor-x cursor-x)
         (set! init-cursor-y cursor-y))
        (is-selecting?
         (change-cursor selecting)
         (set! select-box (list (list init-cursor-x init-cursor-y)
                                (list scaled-cursor-x init-cursor-y)
                                (list scaled-cursor-x scaled-cursor-y)
                                (list init-cursor-x scaled-cursor-y))))
                                                                        
        (is-panning?
         (let* ([current-x (- cursor-x init-cursor-x)]
                [current-y (- cursor-y init-cursor-y)]
                [new-x-offset (get-valid-x-offset (+ current-x x-offset))]
                [new-y-offset (get-valid-y-offset (+ current-y y-offset))])
           (change-cursor panning)
           (send drawer set-transformation (vector transformation-matrix new-x-offset new-y-offset display-scale display-scale rotation))
           (send this refresh)))))
    
    (define bm1 (make-monochrome-bitmap 600 600))
    (send bm1 load-file  "39-megapixels.jpg" 'jpeg #f #t)
    (define bm-dc (new bitmap-dc% [bitmap bm1]))
    (set!-values (image-width image-height) (send bm-dc get-size))

    (define (point-in-img? p)
      (and (> (first p) image-origin-x)
           (< (first p) image-width)
           (> (second p) image-origin-y)
           (< (second p) image-height)))

    (define (within-picture? points)
      (ormap point-in-img? points))
    
    (define (draw-select-box lst)
      (unless (empty? lst)
        (define 1st (first lst))
        (define 2nd (second lst))
        (define 3rd (third lst))
        (define 4th (fourth lst))
        (send/apply (get-dc) draw-line (append 1st 2nd))
        (send/apply (get-dc) draw-line (append 2nd 3rd))
        (send/apply (get-dc) draw-line (append 3rd 4th))
        (send/apply (get-dc) draw-line (append 4th 1st))))
    
    ;; CANVAS REDRAWING
    (define/override (on-paint)
      (define dc (send this get-dc))
      (send dc draw-bitmap bm1 image-origin-x image-origin-y)
      (when display-select-box     (draw-select-box select-box))
      (when display-select-picture (draw-select-box select-box))
      )

    (define/override (on-size width height)
      (cond [(set! canvas-width width)
             (set! canvas-height height)])
      (update-canvas))
    (super-new)))

(define horizontal-divider-panel (new horizontal-panel% [style '(border)] [parent my-frame]))
(define teaching-button-panel (new horizontal-panel% [style '(border)] [parent horizontal-divider-panel] [stretchable-width #f]))
(define graphical-editor-panel (new vertical-panel% [style '(border)] [parent horizontal-divider-panel]))

(define my-canvas (new my-canvas%
                       [parent graphical-editor-panel]
                       [min-height 600]
                       [min-width 800]))

(define editor-display-panel (new horizontal-panel%
                                  [parent graphical-editor-panel]
                                  [style '(border)]	 
                                  [stretchable-height #f]
                                  [stretchable-width #f]
                                  [alignment '(left top)]))

;; GUI geometry management for cursor and pixel coordinate display
(define magnification-display-panel (new vertical-panel% [parent editor-display-panel] [style '(border)]))
(new message% [label "Magnification"] [parent magnification-display-panel])
(define magnification-display (new message% [label " "] [parent magnification-display-panel] [auto-resize #t]))
(define cursor-display-panel (new vertical-panel% [parent editor-display-panel] [style '(border)]))
(new message% [label "Cursor coordinates"] [parent cursor-display-panel])

(define cursor-coordinates-panel (new horizontal-panel% [parent cursor-display-panel]))
(define cursor-x-pane (new pane% [parent cursor-coordinates-panel]))
(define cursor-x-display (new message% [label " "] [parent cursor-x-pane] [auto-resize #t]))
(define cursor-y-pane (new pane% [parent cursor-coordinates-panel]))
(define cursor-y-display (new message% [label " "] [parent cursor-y-pane] [auto-resize #t]))

(define pixel-display-panel (new vertical-panel% [parent editor-display-panel] [style '(border)]))
(new message% [label "Real world coordinates (mm)"] [parent pixel-display-panel])
(define pixel-coordinates-panel (new horizontal-panel% [parent pixel-display-panel]))
(define pixel-x-pane (new pane% [parent pixel-coordinates-panel]))
(define pixel-x-display (new message% [label ""] [parent pixel-x-pane] [auto-resize #t]))
(define pixel-y-pane (new pane% [parent pixel-coordinates-panel]))
(define pixel-y-display (new message% [label ""] [parent pixel-y-pane] [auto-resize #t]))

;; GUI geometry management for editor buttons
(define left-button-panel (new vertical-panel% [parent teaching-button-panel] [style '(border)] [alignment '(left top)] [stretchable-height #f]))
(define right-button-panel (new vertical-panel% [parent teaching-button-panel] [style '(border)] [alignment '(left top)] [stretchable-height #f]))

(define bm (make-monochrome-bitmap 600 600))
(send bm load-file  "model.jpeg" 'jpeg #f #t)

(define fiducial-button
  (new button%
       [label "Fid"]
       [parent left-button-panel]
       [callback (lambda (b e)
                   (cond [(bytes? (get-field selected-img my-canvas))
                          (define pixels (get-field selected-img my-canvas))
                          (define width (get-field selected-img-width my-canvas))
                          (define height (get-field selected-img-height my-canvas))
                          (define model (make-bitmap width height))
                          (send model set-argb-pixels 0 0 width height pixels)
                          (send model save-file "model1.jpeg" 'jpeg 100)
                          (define selected-img (argb-pixels->pict pixels width))
                          (show-pict selected-img)]
                         [else
                          (display "placeholder")]))]))

(define dot-button
  (new button%
       [label "Dot"]
       [parent right-button-panel]
       [callback (lambda (b e )
                   (display "will draw a fucking dot"))]))

(send my-frame show #t)
(send my-canvas show-full-image)
(send my-canvas update-canvas)