src/css/css-setup.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CSS; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: Initial setup of css style attributes
   4 ;;;   Created: 1998-06-18
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;;       $Id: css-setup.lisp,v 1.5 2006-12-26 14:19:18 emarsden Exp $
   8 ;;; ---------------------------------------------------------------------------
   9 ;;;  (c) copyright 1998-2002 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 :CSS)
  31
  32 ;;;; ------------------------------------------------------------------------------------------
  33
  34 ;; This still need some work.
  35
  36 ;; . there is too much cruft left
  37
  38 ;; . the style fetcher should be in certain ways be ignorant of the
  39 ;;   actual style attributes defined.
  40
  41 ;; . this whole business of numbered slots is just nuts. we have
  42 ;;   defstruct which are just as good.
  43
  44 ;; .
  45
  46 ;;;; ------------------------------------------------------------------------------------------
  47
  48 (defvar *device*)
  49 (defvar *style-sheet*)
  50
  51 (defun ensure-style (pt)
  52   (unless (element-style-cache pt)
  53     (setf (element-style-cache pt)
  54       (make-array *n-attrs* :initial-element nil))
  55     (setup-style/1 *device* *style-sheet* pt)))
  56
  57 (defmacro set-style-attr (pt att value)
  58   (error "I am obsolete"))
  59
  60 (defmacro style-attr (pt att &optional default)
  61   (error "I am obsolete"))
  62
  63 (defun create-element-style-cache (pt)
  64   (setf (element-style-cache pt)
  65         (make-array *n-attrs* :initial-element nil #|*null*|# ))
  66   (setup-style/1 *device* *style-sheet* pt))
  67
  68 (defmacro element-style-cache-ref (pt slot)
  69   `(LOCALLY
  70     (DECLARE (OPTIMIZE (SPEED 3) (SAFETY 0)))
  71     (AREF (THE (SIMPLE-ARRAY T (*))
  72                (ELEMENT-STYLE-CACHE ,pt))
  73           (THE FIXNUM ,slot))))
  74
  75 (defmacro %style-attr (pt att &optional default)
  76   (let ((g (gensym)))
  77     (cond ((and (consp att) (eq (car att) 'quote))
  78            `(LET ((,g ,pt))
  79                  ,(if default
  80                       `(let ((,g (ELEMENT-STYLE-CACHE-REF ,g ,(symbol-value (cadr att)))))
  81                          (if ,g ,g ,default))
  82                     `(ELEMENT-STYLE-CACHE-REF ,g ,(symbol-value (cadr att))))))
  83           (t
  84            `(LET ((,g ,pt))
  85                  (let ((,g (SVREF (ELEMENT-STYLE-CACHE ,g) (SYMBOL-VALUE ,att))))
  86                    (if ,g ,g ,default)) )))))
  87
  88 (defmacro %set-style-attr (pt att value)
  89   (let ((g (gensym)))
  90     (cond ((and (consp att) (eq (car att) 'quote))
  91            `(LET ((,g ,pt))
  92                  (SETF (SVREF (ELEMENT-STYLE-CACHE ,g) ,(symbol-value (cadr att)))
  93                        ,value)))
  94           (t
  95            `(LET ((,g ,pt))
  96                  (SETF (SVREF (ELEMENT-STYLE-CACHE ,g)
  97                               (SYMBOL-VALUE ,att)) ,value))))))
  98
  99 \f
 100 ;;;; ------------------------------------------------------------------------------------------
 101 ;;;;  Setting up the Style (part I)
 102 ;;;;
 103
 104 (defvar *dpi*)                          ;to be bound in SETUP-STYLE/1
 105
 106 ;;;; Todo (excrement from css1 spec)
 107
 108 ;;; Since  the intent of  the relative keywords  'bolder' and 'lighter' is to
 109 ;;; darken or lighten the face within the family and because a family may not
 110 ;;; have faces aligned with all  the symbolic weight  values, the matching of
 111 ;;; 'bolder'  is to the  next darker face available on  the client within the
 112 ;;; family and the matching of  'lighter' is to the  next lighter face within
 113 ;;; the family. To be precise, the meaning  of the relative keywords 'bolder'
 114 ;;; and 'lighter' is as follows:
 115
 116 ;;;  * 'bolder' selects the next weight that is assigned to a font that is
 117 ;;;     darker than the inherited one. If there is no such weight, it simply
 118 ;;;     results in the next darker numerical value (and the font remains un-
 119 ;;;     changed), unless the inherited value was '900' in which case the re-
 120 ;;;     sulting weight is also '900'.
 121
 122 ;;;   * 'lighter' is similar, but works in the opposite direction: it selects
 123 ;;;     the next lighter keyword with a different font from the inherited
 124 ;;;     one, unless there is no such font, in which case it selects the next
 125 ;;;     lighter numerical value (and keeps the font unchanged).
 126
 127 ;;; There is no  guarantee that there will  be a darker  face for each of the
 128 ;;; 'font-weight' values; for example, some fonts may  have only a normal and
 129 ;;; a bold  face, others may have eight  different face  weights. There is no
 130 ;;; guarantee on how a UA will map font faces within a  family to weight val-
 131 ;;; ues. The only guarantee is that a  face of a  given value will be no less
 132 ;;; dark than the faces of lighter values.
 133
 134 ;;; ------------------------------------------------------------------------------------------
 135 ;;;  Setting up the Style (part II)
 136 ;;;
 137
 138 (defun kill-style (pt)
 139   (unless (text-element-p pt)
 140     (setf (element-style-cache pt) nil)
 141     (dolist (k (element-children pt))
 142       (kill-style k))))
 143
 144 (defun setup-style (device style-sheet pt &key (first-line-p nil))
 145   (setf (element-style-cache pt)
 146     (make-array *n-attrs* :initial-element nil))
 147   (let ((*first-line-p* first-line-p))
 148     (unless (text-element-p pt)
 149       (setup-style/1 device style-sheet pt)
 150       (dolist (k (element-children pt))
 151         (setup-style device style-sheet k :first-line-p first-line-p)))) )
 152
 153 ;;; ---- Some utils --------------------------------------------------------------------------
 154
 155 (defsubst percentage-p (x)
 156   (and (consp x) (eq (car x) :%)))
 157
 158 ;;; -------------------------------------------------------------------------------------------
 159
 160 (defparameter *cookings*
 161   nil)
 162
 163 (defclass cooking ()
 164   ((property :initarg :property :reader cooking-property)
 165    (applicable-if :initarg :applicable-if :reader cooking-applicable-if)
 166    (value :initarg :value :reader cooking-value)))
 167
 168 (defmacro define-cooking (property &key applicable-if value)
 169   `(progn
 170     ,@(mapcar (lambda (property)
 171                 `(progn
 172                   (setf *cookings* (remove-if (lambda (cooking)
 173                                                 (and (equal (cooking-applicable-if cooking) ',applicable-if)
 174                                                      (eql   (cooking-property cooking) ',property)))
 175                                     *cookings*))
 176                   (push
 177                    (make-instance 'cooking
 178                     :property ',property
 179                     :applicable-if ',applicable-if
 180                     :value ',value)
 181                    *cookings*)))
 182               (if (listp property) property (list property)))))
 183
 184
 185 ;;; on how to speed up style look up
 186
 187 ;;; a. make LOOKUP-ALL-STYLE faster:
 188 ;;;
 189 ;;;    - currently we have a selector for each single assignmnet,
 190 ;;;      which is for from effiecient
 191 ;;;    - cache specifity vectors
 192 ;;;    - use hashing on GI's et all
 193 ;;;    - maybe: compile a selector matcher
 194 ;;;
 195 ;;;
 196 ;;; b. make SETUP-STYLE faster
 197 ;;;
 198 ;;;    - only interpret style attributes on demand.
 199 ;;;      (most attributes are never needed).
 200 ;;;    - don't bother to interpret a non-set margin-width et al
 201 ;;;
 202
 203 (defun interpret-line-height (device value pt)
 204   ;; Big caution here: line-height <number> is inherited differently from <percentage>
 205   (cond ((eq value :normal)
 206          (interpret-line-height device *normal-line-height* pt))
 207         ((numberp value)
 208          (cons '* value))
 209         ((interpret-length device value pt (r2::pt-font-size pt)))))
 210
 211 (defun cooking-function-dependencies (fn &aux res)
 212   (labels ((walk (x)
 213              (cond ((and (consp x) (eq (car x) 'prop))
 214                     (pushnew (cadr x) res))
 215                    ((atom x))
 216                    ((map nil #'walk x)))))
 217     (walk fn)
 218     res))
 219
 220 (defun generate-defclass-1 ()
 221   (let ((props nil))
 222     (loop for prop being the hash-values of *css-properties* do
 223           (when (typep prop 'concrete-property-description)
 224             (push (property-description-name prop) props)))
 225     `(defclass cooked-style ()
 226       ((%element :initform nil)
 227        (r2::computed-margin-left  :initform nil)
 228        (r2::computed-margin-right :initform nil)
 229        (r2::computed-width        :initform nil)
 230        (r2::computed-height       :initform nil)
 231        (%containing-block
 232         :initform nil
 233         :documentation "The style of the containig block")
 234        ,@(mapcar (lambda (prop)
 235                    (list prop
 236                          :initarg (intern (symbol-name prop) :keyword)
 237                          :reader (intern (format nil "COOKED-STYLE-~A" prop))))
 238                  props)))))
 239
 240 (defun generate-setup-style-1 ()
 241   (let ((cookers nil))
 242     (loop for prop being the hash-values of *css-properties* do
 243           (when (typep prop 'concrete-property-description)
 244             (let ((prop (property-description-name prop)))
 245               (let ((fn (cooking-function prop)))
 246                 (push (list prop fn (cooking-function-dependencies fn))
 247                       cookers)))))
 248     (let ((order nil))
 249       (labels ((foo (x)
 250                  (map nil #'foo (third (assoc x cookers)))
 251                  (pushnew x order)))
 252         (map nil #'foo (mapcar #'first cookers))
 253         (setf order (reverse order)))
 254
 255       `(defun setup-style-2 (device style-sheet pt former-cooked)
 256         (let* ((is (element-implicit-style (r2::rc-document r2::*rcontext*) pt))
 257                (ss (element-explicit-style (r2::rc-document r2::*rcontext*) pt))
 258                (style (make-array *n-attrs* :initial-element nil))
 259                (*dpi* (r2::device-dpi *device*))
 260                (dpi (r2::device-dpi *device*))
 261                (res (make-instance 'cooked-style)))
 262           (lookup-all-style style-sheet pt is ss style)
 263           (and (element-parent pt)
 264                (ensure-style (element-parent pt)))
 265           (macrolet ((prop (x)
 266                        `(slot-value res ',x))
 267                      (parent-prop (x)
 268                        `(slot-value former-cooked ',x)))
 269             ,@(mapcar (lambda (prop)
 270                         (let ((att (intern (format nil "@~A" prop) (find-package :css))))
 271                           (with-slots (inheritedp default-value) (gethash prop *css-properties*)
 272                             (let ((cooker (second (assoc prop cookers))))
 273                               `(let ((value (svref style ,(symbol-value att))))
 274                                 (setf value (or value :inherit))
 275                                 (when (not (eq value :inherit))
 276                                   (setf value (,cooker value)))
 277                                 (when (eq value :inherit)
 278                                   (setf value
 279                                         (if (and ,inheritedp (element-parent pt) former-cooked)
 280                                             (%style-attr (element-parent pt) ',att)
 281                                             (,cooker ,default-value))))
 282                                 (setf (slot-value res ',prop) value))))))
 283                       order)
 284             res))) )))
 285
 286 (defmacro generate-setup-style ()
 287   (let ((cookers nil))
 288     (loop for prop being the hash-values of *css-properties* do
 289           (when (typep prop 'concrete-property-description)
 290             (let ((prop (property-description-name prop)))
 291               (let ((fn (cooking-function prop)))
 292                 (push (list prop fn (cooking-function-dependencies fn))
 293                       cookers)))))
 294     (let ((order nil))
 295       (labels ((foo (x)
 296                  (map nil #'foo (third (assoc x cookers)))
 297                  (pushnew x order)))
 298         (map nil #'foo (mapcar #'first cookers))
 299         (setf order (reverse order)))
 300
 301       `(defun setup-style/1 (device style-sheet pt)
 302           (let* ((is (element-implicit-style (r2::rc-document r2::*rcontext*) pt))
 303                  (ss (element-explicit-style (r2::rc-document r2::*rcontext*) pt))
 304                  (cache (element-style-cache pt))
 305                  (style cache)
 306                  (*dpi* (r2::device-dpi *device*))
 307                  (dpi (r2::device-dpi *device*)))
 308             (lookup-all-style style-sheet pt is ss style)
 309             (and (element-parent pt)
 310                  (ensure-style (element-parent pt)))
 311             (macrolet ((prop (x)
 312                          `(svref cache ,(symbol-value (intern (format nil "@~A" x) (find-package :css)))))
 313                        (parent-prop (x)
 314                          `(%style-attr (element-parent pt)
 315                            ',(intern (format nil "@~A" x) (find-package :css)))))
 316               ,@(mapcar (lambda (prop)
 317                           (let ((att (intern (format nil "@~A" prop) (find-package :css))))
 318                             (with-slots (inheritedp default-value) (gethash prop *css-properties*)
 319                               (let ((cooker (second (assoc prop cookers))))
 320                                 `(let ((value (svref cache ,(symbol-value att))))
 321                                   (setf value (or value :inherit))
 322                                   (when (not (eq value :inherit))
 323                                     (setf value (,cooker value)))
 324                                   (when (eq value :inherit)
 325                                     (setf value
 326                                           (if (and ,inheritedp (element-parent pt))
 327                                               (%style-attr (element-parent pt) ',att)
 328                                               (,cooker ,default-value))))
 329                                   (setf (svref cache ,(symbol-value att)) value))))))
 330                         order)))) )))
 331
 332 (defmacro generate-setup-style-3 ()
 333   (let ((cookers nil))
 334     (loop for prop being the hash-values of *css-properties* do
 335           (when (typep prop 'concrete-property-description)
 336             (let ((prop (property-description-name prop)))
 337               (let ((fn (cooking-function prop)))
 338                 (push (list prop fn (cooking-function-dependencies fn))
 339                       cookers)))))
 340     (let ((order nil))
 341       (labels ((foo (x)
 342                  (map nil #'foo (third (assoc x cookers)))
 343                  (pushnew x order)))
 344         (map nil #'foo (mapcar #'first cookers))
 345         (setf order (reverse order)))
 346
 347       `(progn
 348         ,(generate-defclass-1)
 349
 350         (defun setup-style-3 (device document style-sheet pt
 351                               former-cooked
 352                               containing-block-style)
 353           (let* ((is (element-implicit-style document pt))
 354                  (ss (element-explicit-style document pt))
 355                  (style (make-array *n-attrs* :initial-element nil))
 356                  (*dpi* (r2::device-dpi *device*))
 357                  (dpi (r2::device-dpi *device*))
 358                  (res (make-instance 'cooked-style)))
 359             (setf (slot-value res '%element) pt)
 360             (setf (slot-value res '%containing-block) containing-block-style)
 361             (lookup-all-style style-sheet pt is ss style)
 362             (and (element-parent pt)
 363                  (ensure-style (element-parent pt)))
 364             (macrolet ((prop (x)
 365                          `(slot-value res ',x))
 366                        (parent-prop (x)
 367                          `(slot-value former-cooked ',x)))
 368               ,@(mapcar (lambda (prop)
 369                           (let ((att (intern (format nil "@~A" prop) (find-package :css))))
 370                             (with-slots (inheritedp default-value) (gethash prop *css-properties*)
 371                               (let ((cooker (second (assoc prop cookers))))
 372                                 `(let ((value (svref style ,(symbol-value att))))
 373                                   (setf value (or value :inherit))
 374                                   (when (not (eq value :inherit))
 375                                     (setf value (,cooker value)))
 376                                   (when (eq value :inherit)
 377                                     (setf value
 378                                           (if (and ,inheritedp (element-parent pt) former-cooked)
 379                                               (parent-prop ,prop)
 380                                               (,cooker ,default-value))))
 381                                   (setf (slot-value res ',prop) value))))))
 382                         order)
 383               res)))) )))
 384
 385 (defun new-interpret-length (value device font-size pt dpi)
 386   (cond ((consp value)
 387          (let ((unit (car value))
 388                (a (cdr value)))
 389            (case unit
 390              (:px (* 1 a))
 391              (:em
 392               (cond ((and pt (not (realp font-size)))
 393                      (warn "In ~S: font-size not available -- fix your programm."
 394                            'new-interpret-length)
 395                      (round (* a dpi 12) 72))
 396                     (t
 397                      (* a font-size))))
 398              (:ex
 399               (cond ((and pt (not (realp font-size)))
 400                      (warn "In ~S: font-size not available -- fix your programm."
 401                            'new-interpret-length)
 402                      (round (* a dpi 8) 72))
 403                     (t
 404                      (* 2/3 a font-size) ))) ;xxx
 405              (:in (* dpi a))
 406              (:cm (* (round (* a dpi) 2.54))) ;DEVRND
 407              (:mm (* (round (* a dpi) 25.4))) ;DEVRND
 408              (:pt (* (round (* a dpi) 72))) ;DEVRND
 409              (:pc (* (round (* a dpi) 6))) ;DEVRND
 410              (:canvas-h-percentage
 411               ;; DEVRND
 412               (round (* a (r2::device-canvas-width device))
 413                100))
 414              (:canvas-v-percentage
 415               ;; DEVRND
 416               (round (* a (r2::device-canvas-height device))
 417                100))
 418              (otherwise
 419               (error "~S is not a proper css length value." value)) )))
 420         ((eql value 0) 0)
 421         (t
 422          (error "~S is not a proper css length value." value)) ) )
 423
 424 ;;;;
 425 ;;      (m @font-size              t    #'interpret-font-size           t     :medium)
 426 ;;      (m @line-height            t    #'interpret-line-height         nil   '(* . 1.2))
 427 ;;      (m @background-position    nil  #'interpret-background-position nil   '((:% . 0) . (:% . 0)))
 428 ;;      (m @clip                   nil  #'interpret-clip                nil   :auto)
 429
 430
 431 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 432
 433 (defun cooking-function (property)
 434   `(lambda (value)
 435     (cond ,@(mapcar (lambda (cooking)
 436                       (list (cooking-applicable-if cooking)
 437                             (cooking-value cooking)))
 438                     (remove-if-not (lambda (x)
 439                                      (eql (cooking-property x) property))
 440                                    *cookings*))
 441           (t
 442            value))))
 443
 444
 445 (defmacro define-length-cooking (prop)
 446   `(define-cooking ,prop
 447     :applicable-if (and (consp value)
 448                     (member (car value)
 449                      '(:px :em :ex :in :cm :mm :pt :pc :canvas-h-percentage :canvas-v-percentage)))
 450     :value         (new-interpret-length value
 451                     device (prop font-size) pt dpi)))
 452
 453 (defmacro define-percentage-cooking (prop &key base)
 454   `(define-cooking ,prop
 455     :applicable-if (and (consp value) (eql (car value) ':%))
 456     :value         (* 1/100 ,base (cdr value))))
 457
 458
 459 ;; $Log: css-setup.lisp,v $
 460 ;; Revision 1.5  2006-12-26 14:19:18  emarsden
 461 ;; Trivial bugfixes.
 462 ;;
 463 ;; Revision 1.4  2005/03/13 18:00:58  gbaumann
 464 ;; Gross license change
 465 ;;
 466 ;; Revision 1.3  2003/03/13 19:29:17  gilbert
 467 ;; lots of hacking
 468 ;;
 469 ;; Revision 1.2  2002/07/29 12:42:30  gilbert
 470 ;; - NEW-INTERPRET-LENGTH no actually uses its 'font-size' argument
 471 ;;