src/renderer/clim-draw.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RENDERER; Encoding: utf-8; Readtable: GLISP; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: Drawing
   4 ;;;   Created: 2003-03-08
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;;       $Id: clim-draw.lisp,v 1.5 2006-12-29 21:29:34 dlichteblau Exp $
   8 ;;; ---------------------------------------------------------------------------
   9 ;;;  (c) copyright 1997-2003 by Gilbert Baumann
  10
  11 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  12 ;;;  a copy of this software and associated documentation files (the
  13 ;;;  "Software"), to deal in the Software without restriction, including
  14 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  15 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  16 ;;;  permit persons to whom the Software is furnished to do so, subject to
  17 ;;;  the following conditions:
  18 ;;;
  19 ;;;  The above copyright notice and this permission notice shall be
  20 ;;;  included in all copies or substantial portions of the Software.
  21 ;;;
  22 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  23 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  24 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  25 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  26 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  27 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  28 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  29
  30 (in-package :renderer)
  31
  32 ;;; Border
  33
  34 (defun css-color-ink (color)
  35   ;; xxx, we still sometimes wind up with bogus values here
  36   (if (stringp color)
  37       (clim-user::parse-x11-color color)
  38       clim:+black+))
  39
  40 (defun 3d-light-color (base-color)
  41   (multiple-value-bind (i h s) (clim:color-ihs base-color)
  42     (clim:make-ihs-color 1.5 h s)))
  43
  44 (defun 3d-dark-color (base-color)
  45   (multiple-value-bind (i h s) (clim:color-ihs base-color)
  46     (clim:make-ihs-color .8 h s)))
  47
  48 (defun clim-draw-border (medium ix1 iy1 ix2 iy2
  49                          border-top-width border-top-style border-top-color
  50                          border-right-width border-right-style border-right-color
  51                          border-bottom-width border-bottom-style border-bottom-color
  52                          border-left-width border-left-style border-left-color)
  53   (let* ((x1 (- ix1 border-left-width))
  54          (y1 (- iy1 border-top-width))
  55          (x2 (+ ix2 border-right-width))
  56          (y2 (+ iy2 border-bottom-width))
  57          (mx1 (/ (+ x1 ix1) 2))
  58          (my1 (/ (+ y1 iy1) 2))
  59          (mx2 (/ (+ x2 ix2) 2))
  60          (my2 (/ (+ x2 iy2) 2))
  61          )
  62     (labels ((m (x1 y1 x2 y2 x3 y3 x4 y4 style ink ink2 ink3 w)
  63                (case style
  64                  ((:solid)
  65                   (clim:draw-polygon* medium
  66                    (list x1 y1 x2 y2 x3 y3 x4 y4)
  67                    :filled t :ink ink))
  68                  ((:dotted)
  69                   (let ((sw (max w 1)))
  70                     (clim:draw-line* medium
  71                      (/ (+ x1 x2) 2)
  72                      (/ (+ y1 y2) 2)
  73                      (/ (+ x3 x4) 2)
  74                      (/ (+ y3 y4) 2)
  75                      :ink ink
  76                      :line-thickness w
  77                      :line-cap-shape :round
  78                      :line-dashes (vector sw (* 3 sw)))))
  79                  ((:dashed)
  80                   (let ((sw (max 1 w)))
  81                     (clim:draw-line* medium
  82                      (/ (+ x1 x2) 2)
  83                      (/ (+ y1 y2) 2)
  84                      (/ (+ x3 x4) 2)
  85                      (/ (+ y3 y4) 2)
  86                      :ink ink
  87                      :line-thickness w
  88                      :line-cap-shape :square
  89                      :line-dashes (vector (* 3 sw) (* 3 sw)))))
  90                  ((:double)
  91                   (clim:draw-polygon* medium
  92                    (list x1 y1
  93                     (/ (+ x1 x1 x2) 3)
  94                     (/ (+ y1 y1 y2) 3)
  95                     (/ (+ x3 x4 x4) 3)
  96                     (/ (+ y3 y4 y4) 3)
  97                     x4 y4)
  98                    :filled t
  99                    :ink ink)
 100                   (clim:draw-polygon* medium
 101                    (list
 102                     (/ (+ x1 x2 x2) 3) (/ (+ y1 y2 y2) 3)
 103                     x2 y2
 104                     x3 y3
 105                     (/ (+ x3 x3 x4) 3) (/ (+ y3 y3 y4) 3))
 106                    :filled t
 107                    :ink ink))
 108                  ((:groove)
 109                   (clim:draw-polygon* medium
 110                    (list x1 y1
 111                     (/ (+ x1 x2) 2) (/ (+ y1 y2) 2)
 112                     (/ (+ x3 x4) 2) (/ (+ y3 y4) 2)
 113                      x4 y4)
 114                    :filled t :ink ink2)
 115                   (clim:draw-polygon* medium
 116                    (list
 117                     (/ (+ x1 x2) 2) (/ (+ y1 y2) 2)
 118                     x2 y2
 119                     x3 y3
 120                     (/ (+ x3 x4) 2) (/ (+ y3 y4) 2))
 121                    :filled t :ink ink3)
 122                   )
 123                  ((:ridge)
 124                   (clim:draw-polygon* medium
 125                    (list x1 y1
 126                     (/ (+ x1 x2) 2) (/ (+ y1 y2) 2)
 127                     (/ (+ x3 x4) 2) (/ (+ y3 y4) 2)
 128                      x4 y4)
 129                    :filled t :ink ink3)
 130                   (clim:draw-polygon* medium
 131                    (list
 132                     (/ (+ x1 x2) 2) (/ (+ y1 y2) 2)
 133                     x2 y2
 134                     x3 y3
 135                     (/ (+ x3 x4) 2) (/ (+ y3 y4) 2))
 136                    :filled t :ink ink2))
 137                  ((:inset)
 138                   (clim:draw-polygon* medium
 139                    (list x1 y1 x2 y2 x3 y3 x4 y4)
 140                    :filled t :ink ink2))
 141                  ((:outset)
 142                   (clim:draw-polygon* medium
 143                    (list x1 y1 x2 y2 x3 y3 x4 y4)
 144                    :filled t :ink ink3))
 145                  )))
 146       (m  x1 y1  ix1 iy1  ix2 iy1  x2 y1 border-top-style
 147           (css-color-ink border-top-color)
 148           (3d-dark-color (css-color-ink border-top-color)) (3d-light-color (css-color-ink border-top-color))
 149           border-top-width)
 150       (m  x2 y1  ix2 iy1  ix2 iy2  x2 y2 border-right-style
 151           (css-color-ink border-right-color)
 152           (3d-light-color (css-color-ink border-right-color)) (3d-dark-color (css-color-ink border-right-color))
 153           border-right-width)
 154       (m  x2 y2  ix2 iy2  ix1 iy2  x1 y2 border-bottom-style
 155           (css-color-ink border-bottom-color)
 156           (3d-light-color (css-color-ink border-bottom-color)) (3d-dark-color (css-color-ink border-bottom-color))
 157           border-bottom-width)
 158       (m  x1 y2  ix1 iy2  ix1 iy1  x1 y1 border-left-style
 159           (css-color-ink border-left-color)
 160           (3d-dark-color (css-color-ink border-left-color)) (3d-light-color (css-color-ink border-left-color))
 161           border-left-width) )))
 162
 163 ;;;; Text Decoration
 164
 165 ;; Q: what is the precise meaning of "If the element has no content or no text
 166 ;;    content (e.g., the IMG element in HTML), user agents must ignore this
 167 ;;    property."
 168
 169 (defun draw-text-decoration (xx1 yy xx text-decoration color)
 170   (when (consp text-decoration)
 171     (dolist (deco text-decoration)
 172       (case deco
 173         (:underline
 174          (clim:draw-line* clim-user::*pane*
 175           xx1 (+ yy 2) xx (+ yy 2) :ink (clim-user::parse-x11-color color)))
 176         (:overline
 177          ;; xxx hack
 178          (clim:draw-line* clim-user::*pane*
 179           xx1 (- yy 12) xx (- yy 12) :ink (clim-user::parse-x11-color color)))
 180         (:line-through
 181          (clim:draw-line* clim-user::*pane*
 182           xx1 (- yy 6) xx (- yy 6) :ink (clim-user::parse-x11-color color))) ))))
 183
 184 ;;;; Runes
 185
 186 ;; Note: This glorious ITERATE-OVER-RUNES is only used by
 187 ;; CLIM-DRAW-RUNES, so we should dismantle it.
 188
 189 (defun iterate-over-runes/pre/generic (fun runes start end text-style)
 190   (declare (type rod runes)
 191            (type text-style text-style))
 192   (let ((letter-spacing (text-style-letter-spacing text-style))
 193         (word-spacing (text-style-word-spacing text-style))
 194         (font (text-style-font text-style)))
 195     (if (eql letter-spacing :normal) (setf letter-spacing 0))
 196     (if (eql word-spacing :normal) (setf word-spacing 0))
 197     (let ((x 0))
 198       (loop for i from start to (1- end) do
 199             (let* ((rune (aref runes i)))
 200               (if (white-space-rune-p rune) (setf rune #/U+0020))
 201               (progn
 202                 (let ((cw (+ (if (white-space-rune-p rune)
 203                                  (+ (rune-width font rune) word-spacing)
 204                                (rune-width font rune))
 205                              letter-spacing)))
 206                   (funcall fun rune i x cw)
 207                   (incf x cw)))))
 208       x)))
 209
 210 (eval-when (compile eval load)
 211   (defparameter *fetch-rune-width-code*
 212       '(progn
 213         (setf $cw (svref (the (simple-array t (256))
 214                            (svref (the (simple-array t (256)) $fwt)
 215                                   (the (unsigned-byte 8)
 216                                     (ldb (byte 8 8) (the fixnum $rune)))))
 217                    (the (unsigned-byte 8)
 218                      (ldb (byte 8 0) (the fixnum $rune)))))
 219         (when (= $cw -1)
 220           (css-font-desc-ensure-glyph-info $font $rune)
 221           (setf $cw (svref (the (simple-array t (256))
 222                              (svref (the (simple-array t (256)) $fwt)
 223                                     (the (unsigned-byte 8)
 224                                       (ldb (byte 8 8) (the fixnum $rune)))))
 225                      (the (unsigned-byte 8) (ldb (byte 8 0) (the fixnum $rune)))))))))
 226
 227 (defmacro iterate-over-runes/pre* (fun runes start end text-style)
 228   `(locally
 229        (declare (type rod ,runes)
 230                 (type text-style ,text-style)
 231                 (type fixnum ,start ,end)
 232                 #.cl-user:+optimize-very-fast+)
 233      (let* (($font (text-style-font ,text-style))
 234             ($fwt  (css-font-desc-width-table $font)))
 235        (declare (type (simple-array (simple-array t (256)) (256)) $fwt)
 236                 (type css-font-desc $font))
 237        (let ((x 0)
 238              ($rune 0))
 239          (declare (type fixnum $rune))
 240          (declare (type fixnum x))
 241          (loop for i #-GCL of-type #-GCL fixnum from ,start to (the fixnum (1- ,end)) do
 242                (locally
 243                    (declare (fixnum i))
 244                  (setq $rune (rune-code (aref (the rod ,runes) i)))
 245                  (if (white-space-rune-p*/no-nl $rune)
 246                      (setf $rune 32))
 247                  (let (($cw 0))
 248                    (declare (type fixnum $cw))
 249                    ,*fetch-rune-width-code*
 250                    (,fun $rune i x $cw)
 251                    (incf x (the fixnum $cw)) ) ))
 252          x))))
 253
 254 (defmacro iterate-over-runes (fun runes start end text-style white-space)
 255   (assert (eq (car fun) 'lambda))
 256   `((lambda (runes start end text-style white-space)
 257       (cond ((and (eq (text-style-letter-spacing text-style) 0)
 258                   (eq (text-style-word-spacing text-style) :normal))
 259              (ecase white-space
 260                ((:pre)
 261                 (iterate-over-runes/pre* ,fun runes start end text-style)) ))
 262             (t
 263              (ecase white-space
 264                ((:pre)
 265                 (iterate-over-runes/pre/generic ,fun runes start end text-style)) )) ))
 266     ,runes ,start ,end ,text-style ,white-space))
 267
 268 ;;; Aehem, this buffer business must get better ...
 269
 270 (clim-sys:defresource draw-text-buffer ()
 271   :constructor (make-string 1000))
 272
 273 (defun clim-draw-runes* (medium x0 y0 runes start end text-style)
 274   (let ((font nil)
 275         (bptr 0)
 276         bx0 by0 bw)
 277     (clim-sys:using-resource (buffer draw-text-buffer)
 278       (let ((buffer-size (length buffer)))
 279         (prog1
 280             (iterate-over-runes
 281              (lambda (code index x cw)
 282                index
 283                (let* ((fid (css-font-desc-glyph-fid (text-style-font text-style) code))
 284                       (i   (css-font-desc-glyph-index (text-style-font text-style) code)))
 285                  (when (or (not (eq font fid))
 286                            (= bptr buffer-size))
 287                    ;; we have to spill
 288                    (unless (= bptr 0)
 289                      (clim:draw-text* medium (subseq buffer 0 bptr)
 290                                       bx0 by0
 291                                       :text-style font))
 292                    (setf bptr 0
 293                          bx0 (round (+ x0 x))
 294                          by0 (round y0)
 295                          bw 0)
 296                    (setf font fid))
 297                  (setf (aref buffer bptr) (code-char i)
 298                        bptr (+ bptr 1)
 299                        bw (+ bw (round cw)))))
 300              runes start end text-style :pre)
 301           (unless (= bptr 0)
 302             (clim:draw-text* medium (subseq buffer 0 bptr)
 303                              bx0 by0
 304                              :text-style font))) ))))
 305
 306 #+NIL
 307 (climi::def-grecording draw-runes (medium x0 y0 runes start end text-style)
 308         (values x0
 309                 (- y0 10)
 310                 (+ x0 100)
 311                 (+ y 10)))
 312