fontview.lisp

   1 (in-package :common-lisp-user)
   2
   3 (defpackage :fontview
   4   (:use :clim :clim-extensions :clim-lisp :sdl))
   5
   6 (in-package :fontview)
   7
   8 (define-application-frame fontview ()
   9   ((font :initform (make-instance 'sdl::font :staff-line-distance 6))
  10    (shape :initarg :shape :initform :g-clef)
  11    (grid :initform t)
  12    (staff :initform t)
  13    (staff-offset :initform 0)
  14    (view :initform :antialiased)
  15    (zoom :initform 1)
  16    (hoffset :initform 300)
  17    (voffset :initform 300))
  18   (:pointer-documentation t)
  19   (:panes
  20    (fontview :application :width 800 :height 600 :display-function 'display-entry)
  21    (interactor :interactor :width 800 :height 100))
  22   (:layouts
  23    (default
  24        (vertically () fontview interactor))))
  25
  26 (defun display-antialiased-view (frame pane)
  27   (with-slots (font shape staff staff-offset hoffset voffset) frame
  28     (with-translation (pane hoffset voffset)
  29       (sdl::draw-shape pane font shape 0 0)
  30       (when staff
  31         (with-slots ((slt sdl::staff-line-thickness)
  32                      (sld sdl::staff-line-distance)
  33                      (yoff sdl::yoffset))
  34             font
  35           (let ((up (round (+ (* 0.5 slt) yoff)))
  36                 (down (round (- (* 0.5 slt) yoff))))
  37             (loop repeat 5
  38                   for y from (* (+ -2 (* 1/2 staff-offset)) sld) by sld
  39                   do (draw-rectangle* pane
  40                                       (* -10 sld) (- y up)
  41                                       (* 10 sld) (+ y down)))))))))
  42
  43 (defun display-pixel-view (frame pane)
  44   (with-slots (font shape grid zoom hoffset voffset) frame
  45     (with-translation (pane hoffset voffset)
  46       (let ((design (sdl::ensure-design font shape)))
  47         (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* design)
  48           (setf min-x (* 4 (floor min-x))
  49                 min-y (* 4 (floor min-y))
  50                 max-x (* 4 (ceiling max-x))
  51                 max-y (* 4 (ceiling max-y)))
  52           (let ((array (climi::render-to-array design)))
  53             (loop for y from min-y below max-y
  54                   for y-index from 0
  55                   do (loop with x0 = nil
  56                            for x from min-x below max-x
  57                            for x-index from 0
  58                            do (if (zerop (aref array y-index x-index))
  59                                   (when (null x0)
  60                                     (setf x0 x))
  61                                   (unless (null x0)
  62                                     (draw-rectangle* pane (* x0 zoom) (* y zoom) (* x zoom) (* (1+ y) zoom))
  63                                     (setf x0 nil)))
  64                            finally (unless (null x0)
  65                                      (draw-rectangle* pane (* x0 zoom) (* y zoom) (* x zoom) (* (1+ y) zoom)))))
  66             (when grid
  67               (loop for y downfrom 0 above -300 by (* 4 zoom)
  68                     do (draw-rectangle* pane -300 y 300 (1+ y) :ink +blue+))
  69               (loop for y from 0 below 300 by (* 4 zoom)
  70                     do (draw-rectangle* pane -300 y 300 (1+ y) :ink +blue+))
  71               (loop for x downfrom 0 above -300 by (* 4 zoom)
  72                     do (draw-rectangle* pane x -300 (1+ x) 300 :ink +blue+))
  73               (loop for x from 0 below 300 by (* 4 zoom)
  74                     do (draw-rectangle* pane x -300 (1+ x) 300 :ink +blue+))
  75               ;; draw the bounding rectangle
  76               (draw-rectangle* pane
  77                                (* zoom min-x) (* zoom min-y)
  78                                (* zoom max-x) (1+ (* zoom min-y))
  79                                :ink +red+)
  80               (draw-rectangle* pane
  81                                (* zoom min-x) (* zoom max-y)
  82                                (* zoom max-x) (1+ (* zoom max-y))
  83                                :ink +red+)
  84               (draw-rectangle* pane
  85                                (* zoom min-x) (* zoom min-y)
  86                                (1+ (* zoom min-x)) (* zoom max-y)
  87                                :ink +red+)
  88               (draw-rectangle* pane
  89                                (* zoom max-x) (* zoom min-y)
  90                                (1+ (* zoom max-x)) (* zoom max-y)
  91                                :ink +red+)
  92               ;; draw the reference point
  93               (draw-rectangle* pane -300 0 300 1 :ink +red+)
  94               (draw-rectangle* pane 0 -300 1 300 :ink +red+))))))))
  95
  96 (defun display-entry (frame pane)
  97   (with-slots (view) frame
  98     (if (eq view :antialiased)
  99         (display-antialiased-view frame pane)
 100         (display-pixel-view frame pane))))
 101
 102 (defun fontview (&optional (shape :g-clef))
 103   (let ((frame (make-application-frame 'fontview :shape shape)))
 104     (run-frame-top-level frame)))
 105
 106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 107 ;;;
 108 ;;; Commands
 109
 110 (define-fontview-command (com-quit :name t) ()
 111   (frame-exit *application-frame*))
 112
 113 (define-fontview-command (com-show :name t) ((symbol 'symbol))
 114   (with-slots (shape) *application-frame*
 115     (setf shape symbol)))
 116
 117 (define-fontview-command (com-zoom-in :name t :keystroke (#\i :control)) ()
 118   (with-slots (zoom) *application-frame*
 119     (when (< zoom 10) (incf zoom))))
 120
 121 (define-fontview-command (com-zoom-out :name t :keystroke (#\i :control)) ()
 122   (with-slots (zoom) *application-frame*
 123     (when (> zoom 1) (decf zoom))))
 124
 125 (define-fontview-command (com-zoom-to :name t) ((i 'integer))
 126   (with-slots (zoom) *application-frame*
 127     (setf zoom (min (max i 1) 10))))
 128
 129 (define-fontview-command (com-size :name t) ((i 'integer))
 130   (with-slots (font) *application-frame*
 131     (when (oddp i) (incf i))
 132     (setf font (make-instance 'sdl::font :staff-line-distance (min (max i 6) 20)))))
 133
 134 (define-fontview-command (com-grid-on :name t) ()
 135   (with-slots (grid) *application-frame*
 136     (setf grid t)))
 137
 138 (define-fontview-command (com-grid-off :name t) ()
 139   (with-slots (grid) *application-frame*
 140     (setf grid nil)))
 141
 142 (define-fontview-command (com-staff-on :name t) ()
 143   (with-slots (staff) *application-frame*
 144     (setf staff t)))
 145
 146 (define-fontview-command (com-staff-off :name t) ()
 147   (with-slots (staff) *application-frame*
 148     (setf staff nil)))
 149
 150 (define-fontview-command (com-staff-up :name t) ()
 151   (with-slots (staff-offset) *application-frame*
 152     (when (> staff-offset -4)
 153       (decf staff-offset))))
 154
 155 (define-fontview-command (com-staff-down :name t) ()
 156   (with-slots (staff-offset) *application-frame*
 157     (when (< staff-offset 4)
 158       (incf staff-offset))))
 159
 160 (define-fontview-command (com-staff-middle :name t) ()
 161   (with-slots (staff-offset) *application-frame*
 162     (setf staff-offset 0)))
 163
 164 (define-fontview-command (com-pixel-view :name t) ()
 165   (with-slots (view) *application-frame*
 166     (setf view :pixel)))
 167
 168 (define-fontview-command (com-antialiased-view :name t) ()
 169   (with-slots (view) *application-frame*
 170     (setf view :antialiased)))
 171