<commit_before>;;; Copyright (c) 2011 <NAME>, All rights reserved.
;;; See COPYRIGHT file for details.
;;;
;;; A simple viewer for opticl images
;;;
;;; Note: Originally based on Troels' Henriksen's
;;; clim-demo:image-viewer
;;;

(in-package :spectacle)

(defclass spectacle-gadget (value-gadget)
  ((transform-parameters :accessor transform-parameters :initarg :transform-parameters)
   (transform :accessor transform :initarg :transform)
   (lock-x-and-y-scale :accessor lock-x-and-y-scale :initarg :lock-x-and-y-scale)
   (transformed-image :accessor transformed-image :initarg :transformed-image)
   (image-pattern :accessor image-pattern :initarg :image-pattern))
  (:default-initargs :value nil
    :transform-parameters #(1d0 1d0 0d0 0d0 0d0 0d0 0d0)
    :lock-x-and-y-scale t
    :transform nil
    :transformed-image nil
    :image-pattern nil))

(defmethod (setf gadget-value) :after (new-value (gadget spectacle-gadget)
                                                 &key &allow-other-keys)
  (handle-repaint gadget (or (pane-viewport-region gadget)
                             (sheet-region gadget))))

(defclass spectacle-pane (spectacle-gadget basic-gadget) ())

(defun y-scale-callback (gadget scale)
  (declare (ignore gadget))
  (let ((viewer (find-pane-named *application-frame* 'viewer)))
    (with-accessors ((image gadget-value)
                     (transform-parameters transform-parameters)
                     (transform transform)
                     (lock-x-and-y-scale lock-x-and-y-scale))
        viewer
      (let ((y-scale-param 0)
            (x-scale-param 1))
        (unless (equal (elt transform-parameters y-scale-param) scale)
          (let ((x-scale-slider (find-pane-named *application-frame* 'x-scale)))
            (when lock-x-and-y-scale
              (setf (gadget-value x-scale-slider) scale
                    (elt transform-parameters x-scale-param) scale)))
          (setf (elt transform-parameters y-scale-param) scale
                transform nil)
          (handle-repaint viewer (sheet-region viewer)))))))

(defun x-scale-callback (gadget scale)
  (declare (ignore gadget))
  (let ((viewer (find-pane-named *application-frame* 'viewer)))
    (with-accessors ((image gadget-value)
                     (transform-parameters transform-parameters)
                     (transform transform)
                     (lock-x-and-y-scale lock-x-and-y-scale))
        viewer
      (let ((y-scale-param 0)
            (x-scale-param 1))
        (unless (equal (elt transform-parameters x-scale-param) scale)
          (let ((y-scale-slider (find-pane-named *application-frame* 'y-scale)))
            (when lock-x-and-y-scale
              (setf (gadget-value y-scale-slider) scale
                    (elt transform-parameters y-scale-param) scale)))
          (setf (elt transform-parameters x-scale-param) scale
                transform nil)
          (handle-repaint viewer (sheet-region viewer)))))
    (handle-repaint viewer (sheet-region viewer))))

(defun theta-callback (gadget degrees)
  (declare (ignore gadget))
  (let ((viewer (find-pane-named *application-frame* 'viewer)))
    (with-accessors ((image gadget-value)
                     (transform-parameters transform-parameters)
                     (transform transform))
        viewer
      (let ((param 6)
            (rads (mod (* pi degrees (/ 180)) (* 2 pi))))
        (unless (equal (elt transform-parameters param) rads)
          (setf (elt transform-parameters param) rads
                transform nil))))
    (handle-repaint viewer (sheet-region viewer))))

(defun y-shear-callback (gadget shear)
  (declare (ignore gadget))
  (let ((viewer (find-pane-named *application-frame* 'viewer)))
    (with-accessors ((image gadget-value)
                     (transform-parameters transform-parameters)
                     (transform transform))
        viewer
      (let ((param 4))
        (unless (equal (elt transform-parameters param) shear)
          (setf (elt transform-parameters param) shear
                transform nil))))
    (handle-repaint viewer (sheet-region viewer))))

(defun x-shear-callback (gadget shear)
  (declare (ignore gadget))
  (let ((viewer (find-pane-named *application-frame* 'viewer)))
    (with-accessors ((image gadget-value)
                     (transform-parameters transform-parameters)
                     (transform transform))
        viewer
      (let ((param 5))
        (unless (equal (elt transform-parameters param) shear)
          (setf (elt transform-parameters param) shear
                transform nil))))
    (handle-repaint viewer (sheet-region viewer))))


(define-application-frame spectacle ()
  ()
  (:menu-bar menubar-command-table)
  (:panes
   (viewer (make-pane 'spectacle-pane
                      :background +black+
                      :foreground +white+
                      :width 500))
   (lock-scale :toggle-button
               :label "Lock X and Y Scale"
               :value t
               :value-changed-callback
               (lambda (gadget value)
                 (declare (ignore gadget))
                 (let ((viewer (find-pane-named *application-frame* 'viewer)))
                   (with-accessors ((lock-x-and-y-scale lock-x-and-y-scale))
                       viewer
                     (setf lock-x-and-y-scale value)))))
   (y-scale :slider
            :min-value 0.1
            :max-value 4
            :decimal-places 2
            :value 1.0d0
            :show-value-p t
            :orientation :horizontal
            :drag-callback #'y-scale-callback
            :value-changed-callback 'y-scale-callback)
   (x-scale :slider
            :min-value 0.1
            :max-value 4
            :decimal-places 2
            :value 1.0d0
            :show-value-p t
            :orientation :horizontal
            :drag-callback #'x-scale-callback
            :value-changed-callback 'x-scale-callback)
   (theta :slider
          :min-value -180
          :max-value 180
          :decimal-places 1
          :value 0
          :show-value-p t
          :orientation :horizontal
          :drag-callback #'theta-callback
          :value-changed-callback 'theta-callback)
   (y-shear :slider
            :min-value -5
            :max-value 5
            :decimal-places 2
            :value 0.0d0
            :show-value-p t
            :orientation :horizontal
            :drag-callback #'y-shear-callback
            :value-changed-callback 'y-shear-callback)
   (reset-button :push-button
                 :label "Reset Parameters"
                 :activate-callback (lambda (gadget)
                                      (declare (ignore gadget))
                                      (com-reset)))
   (x-shear :slider
            :min-value -5
            :max-value 5
            :decimal-places 2
            :value 0.0d0
            :show-value-p t
            :orientation :horizontal
            :drag-callback #'x-shear-callback
            :value-changed-callback 'x-shear-callback)
   (interactor :interactor
               :text-style (make-text-style :sans-serif nil nil)
               :min-height 100))
  (:layouts
   (default (vertically ()
              (4/5 (horizontally ()
                     (4/5 viewer)
                     (1/5 (vertically ()<commit_msg>fix height so the window's not so tall<commit_after>;;; Copyright (c) 2011 <NAME>, All rights reserved.
;;; See COPYRIGHT file for details.
;;;
;;; A simple viewer for opticl images
;;;
;;; Note: Originally based on Troels' Henriksen's
;;; clim-demo:image-viewer
;;;

(in-package :spectacle)

(defclass spectacle-gadget (value-gadget)
  ((transform-parameters :accessor transform-parameters :initarg :transform-parameters)
   (transform :accessor transform :initarg :transform)
   (lock-x-and-y-scale :accessor lock-x-and-y-scale :initarg :lock-x-and-y-scale)
   (transformed-image :accessor transformed-image :initarg :transformed-image)
   (image-pattern :accessor image-pattern :initarg :image-pattern))
  (:default-initargs :value nil
    :transform-parameters #(1d0 1d0 0d0 0d0 0d0 0d0 0d0)
    :lock-x-and-y-scale t
    :transform nil
    :transformed-image nil
    :image-pattern nil))

(defmethod (setf gadget-value) :after (new-value (gadget spectacle-gadget)
                                                 &key &allow-other-keys)
  (handle-repaint gadget (or (pane-viewport-region gadget)
                             (sheet-region gadget))))

(defclass spectacle-pane (spectacle-gadget basic-gadget) ())

(defun y-scale-callback (gadget scale)
  (declare (ignore gadget))
  (let ((viewer (find-pane-named *application-frame* 'viewer)))
    (with-accessors ((image gadget-value)
                     (transform-parameters transform-parameters)
                     (transform transform)
                     (lock-x-and-y-scale lock-x-and-y-scale))
        viewer
      (let ((y-scale-param 0)
            (x-scale-param 1))
        (unless (equal (elt transform-parameters y-scale-param) scale)
          (let ((x-scale-slider (find-pane-named *application-frame* 'x-scale)))
            (when lock-x-and-y-scale
              (setf (gadget-value x-scale-slider) scale
                    (elt transform-parameters x-scale-param) scale)))
          (setf (elt transform-parameters y-scale-param) scale
                transform nil)
          (handle-repaint viewer (sheet-region viewer)))))))

(defun x-scale-callback (gadget scale)
  (declare (ignore gadget))
  (let ((viewer (find-pane-named *application-frame* 'viewer)))
    (with-accessors ((image gadget-value)
                     (transform-parameters transform-parameters)
                     (transform transform)
                     (lock-x-and-y-scale lock-x-and-y-scale))
        viewer
      (let ((y-scale-param 0)
            (x-scale-param 1))
        (unless (equal (elt transform-parameters x-scale-param) scale)
          (let ((y-scale-slider (find-pane-named *application-frame* 'y-scale)))
            (when lock-x-and-y-scale
              (setf (gadget-value y-scale-slider) scale
                    (elt transform-parameters y-scale-param) scale)))
          (setf (elt transform-parameters x-scale-param) scale
                transform nil)
          (handle-repaint viewer (sheet-region viewer)))))
    (handle-repaint viewer (sheet-region viewer))))

(defun theta-callback (gadget degrees)
  (declare (ignore gadget))
  (let ((viewer (find-pane-named *application-frame* 'viewer)))
    (with-accessors ((image gadget-value)
                     (transform-parameters transform-parameters)
                     (transform transform))
        viewer
      (let ((param 6)
            (rads (mod (* pi degrees (/ 180)) (* 2 pi))))
        (unless (equal (elt transform-parameters param) rads)
          (setf (elt transform-parameters param) rads
                transform nil))))
    (handle-repaint viewer (sheet-region viewer))))

(defun y-shear-callback (gadget shear)
  (declare (ignore gadget))
  (let ((viewer (find-pane-named *application-frame* 'viewer)))
    (with-accessors ((image gadget-value)
                     (transform-parameters transform-parameters)
                     (transform transform))
        viewer
      (let ((param 4))
        (unless (equal (elt transform-parameters param) shear)
          (setf (elt transform-parameters param) shear
                transform nil))))
    (handle-repaint viewer (sheet-region viewer))))

(defun x-shear-callback (gadget shear)
  (declare (ignore gadget))
  (let ((viewer (find-pane-named *application-frame* 'viewer)))
    (with-accessors ((image gadget-value)
                     (transform-parameters transform-parameters)
                     (transform transform))
        viewer
      (let ((param 5))
        (unless (equal (elt transform-parameters param) shear)
          (setf (elt transform-parameters param) shear
                transform nil))))
    (handle-repaint viewer (sheet-region viewer))))


(define-application-frame spectacle ()
  ()
  (:menu-bar menubar-command-table)
  (:panes
   (viewer (make-pane 'spectacle-pane
                      :background +black+
                      :foreground +white+
                      :width 500))
   (lock-scale :toggle-button
               :label "Lock X and Y Scale"
               :value t
               :value-changed-callback
               (lambda (gadget value)
                 (declare (ignore gadget))
                 (let ((viewer (find-pane-named *application-frame* 'viewer)))
                   (with-accessors ((lock-x-and-y-scale lock-x-and-y-scale))
                       viewer
                     (setf lock-x-and-y-scale value)))))
   (y-scale :slider
            :min-value 0.1
            :max-value 4
            :decimal-places 2
            :value 1.0d0
            :show-value-p t
            :orientation :horizontal
            :drag-callback #'y-scale-callback
            :value-changed-callback 'y-scale-callback)
   (x-scale :slider
            :min-value 0.1
            :max-value 4
            :decimal-places 2
            :value 1.0d0
            :show-value-p t
            :orientation :horizontal
            :drag-callback #'x-scale-callback
            :value-changed-callback 'x-scale-callback)
   (theta :slider
          :min-value -180
          :max-value 180
          :decimal-places 1
          :value 0
          :show-value-p t
          :orientation :horizontal
          :drag-callback #'theta-callback
          :value-changed-callback 'theta-callback)
   (y-shear :slider
            :min-value -5
            :max-value 5
            :decimal-places 2
            :value 0.0d0
            :show-value-p t
            :orientation :horizontal
            :drag-callback #'y-shear-callback
            :value-changed-callback 'y-shear-callback)
   (x-shear :slider
            :min-value -5
            :max-value 5
            :decimal-places 2
            :value 0.0d0
            :show-value-p t
            :orientation :horizontal
            :drag-callback #'x-shear-callback
            :value-changed-callback 'x-shear-callback)
   (reset-button :push-button
                 :label "Reset Parameters"
                 :activate-callback (lambda (gadget)
                                      (declare (ignore gadget))
                                      (com-reset)))
   (interactor :interactor
               :text-style (make-text-style :sans-serif nil nil)
               :min-height 100))
  (:layouts
   (default (vertically (:height 250)
              (4/5 (horizontally ()
                     (4/5 viewer)
                     (1/5 (vertically ()
{'fraction_non_alphanumeric': 0.11970006816632583, 'fraction_numerical': 0.010429447852760737, 'mean_word_length': 1.843768172126381, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 5, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 8, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '295278', 'n_tokens_mistral': 4399, 'n_tokens_neox': 4149, 'n_words': 1023}