src/css/css-properties.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CSS; Encoding: utf-8; Readtable: GLISP; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: Parsing CSS1 Style Sheets (according to W3C REC-CSS1-961217)
   4 ;;;   Created: 1998-02-08
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;;       $Id: css-properties.lisp,v 1.9 2007-07-07 15:03:56 dlichteblau 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 ;;;;;;;;;;;;;;;
  31
  32 (in-package :CSS)
  33
  34 (eval-when (eval compile load)
  35
  36 (defparameter *cookings*
  37   nil)
  38
  39 ;;; ------------------------------------------------------------------------------------------
  40 ;;;  Some Default Values
  41
  42 #||
  43 (defparameter *thin-border*             '(:px . 1))
  44 (defparameter *medium-border*           '(:px . 2))
  45 (defparameter *thick-border*            '(:px . 5))
  46 ||#
  47
  48 ;; unfortunatly we lost cooking on default values:
  49 (defparameter *thin-border*             1)
  50 (defparameter *medium-border*           2)
  51 (defparameter *thick-border*            5)
  52
  53
  54 (defparameter *normal-line-height*      '1.2)
  55 (defparameter *initial-font-family*     '("times"))
  56 (defparameter *initial-color*           '"#000")
  57 ;; 3/2 ist eigentlich etwas bisschen heftig!
  58 (defparameter *font-scaling-factor*     3/2)
  59 (defparameter *medium-font-size*        '(:pt . 12))
  60
  61 ;;; ------------------------------------------------------------------------------------------
  62 ;;;  Concrete Properties
  63 ;;;
  64
  65 (define-css-property background-attachment
  66     :default-value :scroll
  67     :value (or :scroll :fixed)
  68     :inheritedp nil)
  69
  70 (define-css-property background-color
  71     :default-value :transparent
  72     :value (or <a-color> :transparent)
  73     :inheritedp nil)
  74
  75 (define-css-property background-image
  76     :default-value :none
  77     :value (or <url> :none)
  78     :inheritedp nil)
  79
  80 (define-css-property background-repeat
  81     :default-value :repeat
  82     :value (or :repeat :repeat-x :repeat-y :no-repeat)
  83     :inheritedp nil)
  84
  85 (define-css-property color
  86     :default-value *initial-color*
  87     :value <a-color>
  88     :inheritedp t)
  89
  90 (define-css-property border-top-style
  91     :default-value :none
  92     :inheritedp nil
  93     :value (or :none :dotted :dashed :solid :double :groove :ridge :inset :outset))
  94
  95 (define-css-property border-right-style
  96     :default-value :none
  97     :inheritedp nil
  98     :value (or :none :dotted :dashed :solid :double :groove :ridge :inset :outset))
  99
 100 (define-css-property border-bottom-style
 101     :default-value :none
 102     :inheritedp nil
 103     :value (or :none :dotted :dashed :solid :double :groove :ridge :inset :outset))
 104
 105 (define-css-property border-left-style
 106     :default-value :none
 107     :inheritedp nil
 108     :value (or :none :dotted :dashed :solid :double :groove :ridge :inset :outset))
 109
 110 (define-css-property line-height
 111     :inheritedp t
 112     :value (or :normal
 113                <non-negative-length>
 114                <non-negative-percentage>
 115                <non-negative-number>)
 116     :default-value '(* . 1.2)
 117     ;; interpret-line-height
 118     )
 119
 120 (define-css-property word-spacing
 121     :inheritedp t
 122     :value (or :normal <length>)
 123     :default-value :normal
 124     ;; interpret-word-spacing
 125     )
 126
 127 (define-css-property font-style
 128     :inheritedp t
 129     :value (or :italic :oblique :normal)
 130     :default-value :normal
 131     )
 132
 133 (define-css-property font-variant
 134     :inheritedp t
 135     :value (or :small-caps :normal)
 136     :default-value :normal)
 137
 138 (define-css-property font-weight
 139     :inheritedp t
 140     :value <a-font-weight>
 141     :default-value :normal)
 142
 143 (define-css-property clear
 144     :inheritedp nil
 145     :value (or :none :left :right :both)
 146     :default-value :none)
 147
 148 (define-css-property float
 149     :value (or :left :right :none)
 150     :inheritedp nil
 151     :default-value :none)
 152
 153 (define-css-property display
 154     :value (or :block :inline :list-item :none
 155                :run-in
 156                ;; CSS2
 157                :run-in :compact :marker
 158
 159                ;;; Table stuff:
 160
 161                :table
 162                :inline-table
 163                :table-row-group
 164                :table-header-group
 165                :table-footer-group
 166                :table-row
 167                :table-column-group
 168                :table-column
 169                :table-cell
 170                :table-caption
 171
 172                ;; :inherit
 173                )
 174     ;; ### CSS1 has :block here while CSS2 has :inline
 175     :default-value :inline
 176     :inheritedp nil
 177     ;;xxx float -> block
 178     ;;xxx CSS2: default: inline
 179     )
 180
 181 (define-css-property white-space
 182     :value (or :normal :pre :nowrap)
 183     :inheritedp t
 184     :default-value :normal)
 185
 186 (define-css-property list-style-type
 187     :value <a-list-style-type>
 188     :inheritedp t
 189     :default-value :disc)
 190
 191 (define-css-property list-style-position
 192     :value (or :inside :outside)
 193     :inheritedp t
 194     :default-value :outside)
 195
 196 (define-css-property text-align
 197     :value (or :left :right :center :justify)
 198     :inheritedp t
 199     :default-value :left)
 200
 201 (define-css-property text-transform
 202     :value (or :capitalize :uppercase :lowercase :none)
 203     :inheritedp t
 204     :default-value :none)
 205
 206 (define-css-property text-decoration
 207     :value (or :none
 208                (barbar :underline :overline :line-through :blink))
 209     :inheritedp nil
 210     :default-value :none)
 211
 212 (define-css-property text-shadow
 213     :value (or :none
 214                (comma-list
 215                 (mungle
 216                  (barbar (mungle (? <a-color>) (lambda (x) (and x (list :color x))))
 217                          (mungle
 218                           (& (mungle <length> (lambda (x) (list :dx x)))
 219                              (mungle <length> (lambda (x) (list :dy x)))
 220                              (mungle (? <length>) (lambda (x) (and x (list :radius x)))))
 221                           (lambda (x) (reduce #'append x))))
 222                  (lambda (x) (list `(:shadow ,@(reduce #'append x)))))))
 223     ;; Now this is funny they cannot even read their own BNF:
 224     ;; "Each shadow effect must specify a shadow offset and may
 225     ;; optionally specify a blur radius and a shadow color. "
 226     :default-value :none
 227     :inheritedp nil
 228     ;; :applies-to all
 229     ;; :media visual
 230     )
 231
 232 (define-css-property padding-top
 233     :value (or <non-negative-length> <non-negative-percentage>)
 234     :default-value 0
 235     :inheritedp nil
 236     :percentage-base ??)
 237
 238 (define-css-property padding-right
 239     :value (or <non-negative-length> <non-negative-percentage>)
 240     :default-value 0
 241     :inheritedp nil
 242     :percentage-base ??)
 243
 244 (define-css-property padding-bottom
 245     :value (or <non-negative-length> <non-negative-percentage>)
 246     :default-value 0
 247     :inheritedp nil
 248     :percentage-base ??)
 249
 250 (define-css-property padding-left
 251     :value (or <non-negative-length> <non-negative-percentage>)
 252     :default-value 0
 253     :inheritedp nil
 254     :percentage-base ??)
 255
 256 (define-css-property margin-top
 257     :value <a-margin>
 258     :default-value 0
 259     :inheritedp nil
 260     :percentage-base ??)
 261
 262 (define-css-property margin-right
 263     :value <a-margin>
 264     :default-value 0
 265     :inheritedp nil
 266     :percentage-base ??)
 267
 268 (define-css-property margin-bottom
 269     :value <a-margin>
 270     :default-value 0
 271     :inheritedp nil
 272     :percentage-base ??)
 273
 274 (define-css-property margin-left
 275     :value <a-margin>
 276     :default-value 0
 277     :inheritedp nil
 278     :percentage-base ??)
 279
 280 (define-css-property letter-spacing
 281     :value (or :normal <length>)
 282     :default-value 0
 283     :inheritedp t
 284     ;; xxx #'interpret-letter-spacing
 285     )
 286
 287 (define-css-property vertical-align
 288     :value (or :baseline
 289                :sub :super
 290                :top :text-top :middle :bottom :text-bottom
 291                <percentage>
 292                <length>                 ;css2
 293                )
 294     :default-value :baseline
 295     :inheritedp nil
 296     :percentage-base ???
 297     ;; xxx #'interpret-vertical-align
 298     )
 299
 300 (define-css-property text-indent
 301     :value (or <length> <percentage>)
 302     :default-value 0
 303     :inheritedp t
 304     :percentage-base ???
 305     ;; xxx #'interpret-text-indent
 306     )
 307
 308 (define-css-property border-top-width
 309     :value (or :thin :medium :thick <non-negative-length>)
 310     :default-value 2
 311     :inheritedp nil
 312     ;; xxx #'interpret-border-width
 313     )
 314
 315 (define-css-property border-right-width
 316     :value (or :thin :medium :thick <non-negative-length>)
 317     :default-value 2
 318     :inheritedp nil
 319     ;; xxx #'interpret-border-width
 320     )
 321
 322 (define-css-property border-bottom-width
 323     :value (or :thin :medium :thick <non-negative-length>)
 324     :default-value 2
 325     :inheritedp nil
 326     ;; xxx #'interpret-border-width
 327     )
 328
 329 (define-css-property border-left-width
 330     :value (or :thin :medium :thick <non-negative-length>)
 331     :default-value 2
 332     :inheritedp nil
 333     ;; xxx #'interpret-border-width
 334     )
 335
 336 (define-css-property width
 337     :value (or <non-negative-length>
 338                <non-negative-percentage>
 339                :auto)
 340     :default-value :auto
 341     :inheritedp nil
 342     )
 343
 344 (define-css-property height
 345     :value (or <non-negative-length>
 346                :auto)
 347     :default-value :auto
 348     :inheritedp nil)
 349
 350 (define-css-property list-style-image
 351     :value (or <url> :none)
 352     :default-value :none
 353     :inheritedp t
 354     )
 355
 356 (define-css-property font-size
 357     :value (or <absolute-size>
 358                <relative-size>
 359                <non-negative-length>
 360                <non-negative-percentage>)
 361     :inheritedp t
 362     :default-value '(:pt . 12))
 363
 364 (define-css-property border-top-color
 365     :value <a-color>
 366     :default-value "black"
 367     :inheritedp nil                       ;xxx not sure
 368     )
 369
 370 (define-css-property border-right-color
 371     :value <a-color>
 372     :default-value "black"
 373     :inheritedp nil                       ;xxx not sure
 374     )
 375
 376 (define-css-property border-bottom-color
 377     :value <a-color>
 378     :default-value "black"
 379     :inheritedp nil                       ;xxx not sure
 380     )
 381
 382 (define-css-property border-left-color
 383     :value <a-color>
 384     :default-value "black"
 385     :inheritedp nil                       ;xxx not sure
 386     )
 387
 388 ;;; Missing:
 389
 390 ;(("background-position" . P/BACKGROUND-POSITION)
 391 ; ("border" . P/BORDER)
 392 ; )
 393
 394 ;;; Missing:
 395 ;; BACKGROUND-POSITION -- weird
 396
 397 (define-css-property background-position
 398     :value <a-background-position>
 399     :default-value (cons '(:% . 0) '(:% . 0))
 400     :inheritedp nil)
 401
 402 (define-cooking background-position
 403     :applicable-if t
 404     :value (cons
 405             (if (and (consp (car value))
 406                      (member (caar value)
 407                              '(:px :em :ex :in :cm :mm :pt :pc :canvas-h-percentage :canvas-v-percentage)))
 408                 (new-interpret-length (car value)
 409                                       device (prop font-size) pt dpi)
 410                 (car value))
 411             (if (and (consp (cdr value))
 412                      (member (cadr value)
 413                              '(:px :em :ex :in :cm :mm :pt :pc :canvas-h-percentage :canvas-v-percentage)))
 414                 (new-interpret-length (cdr value)
 415                                       device (prop font-size) pt dpi)
 416                 (cdr value))))
 417
 418 (define-css-property font-family
 419     :value <a-font-family>
 420     :default-value *initial-font-family*
 421     :inheritedp t)
 422
 423 (define-css-property marker-offset
 424     :value (or :inherit :auto <length>)
 425     :default-value :auto
 426     :inheritedp nil
 427     ;; css2
 428     ;;
 429     )
 430
 431 (define-css-property quotes
 432     :value (or :inherit
 433                :none
 434                (+ (& <string> <string>)))
 435     :inheritedp t
 436     :default-value (list (list "\"" "\"")
 437                          (list "\'" "\'")))
 438
 439 ;;;;;;;;;;;;;;;;;;;;
 440
 441 (define-css-property position
 442     :value (or :static :relative :absolute :fixed :inherit)
 443     :default-value :static
 444     :inheritedp nil)
 445
 446 (define-css-property top
 447     :value (or <length> <percentage> :auto :inherit)
 448     :default-value :auto
 449     :inheritedp nil)
 450
 451 (define-css-property right
 452     :value (or <length> <percentage> :auto :inherit)
 453     :default-value :auto
 454     :inheritedp nil)
 455
 456 (define-css-property bottom
 457     :value (or <length> <percentage> :auto :inherit)
 458     :default-value :auto
 459     :inheritedp nil)
 460
 461 (define-css-property left
 462     :value (or <length> <percentage> :auto :inherit)
 463     :default-value :auto
 464     :inheritedp nil)
 465
 466 (define-css-property z-index
 467     :value (or <integer> :auto :inherit)
 468     :default-value :auto
 469     :inheritedp nil)
 470
 471 (define-css-property overflow
 472     :value (or :visible :hidden :scroll :auto :inherit)
 473     :default-value :visible
 474     :inheritedp nil)
 475
 476 (define-css-property clip
 477     :value (or <shape> :auto :inherit)
 478     :default-value :auto
 479     :inheritedp nil)
 480
 481 (define-css-property content
 482     :value (+ (or (mungle <string>
 483                           (lambda (x) `(:string ,x)))
 484                   (mungle <url>
 485                           (lambda (x) `(:url ,x)))
 486                   (function :counter <ident>)
 487                   (function :counter <ident> <a-list-style-type>)
 488                   (function :counters <ident> <string>)
 489                   (function :counters <ident> <string> <a-list-style-type>)
 490                   ;; <counter> <attrX>
 491                   :open-quote
 492                   :close-quote
 493                   :no-open-quote
 494                   :no-close-quote))
 495     :default-value nil
 496     :inheritedp nil)
 497
 498 (define-css-property counter-reset
 499     :value (or :none
 500                :inherit
 501                (+ (& <ident> (mungle (? <integer>) (lambda (x) (or x 0))))))
 502     :default-value :none
 503     :inheritedp nil)
 504
 505 (define-css-property counter-increment
 506     :value (or :none
 507                :inherit
 508                (+ (& <ident> (mungle (? <integer>) (lambda (x) (or x 1))))))
 509     :default-value :none
 510     :inheritedp nil)
 511
 512 (define-css-property orig-width
 513     :value :khjdskdjshaks               ;xxx
 514     )
 515
 516 #||
 517 (define-css-property caption-side
 518     :value (or :top :bottom :left :right :inherit)
 519     :inheritedp t
 520     :default-value :top)
 521 ||#
 522
 523 ;;; ------------------------------------------------------------------------------------------
 524 ;;;  Shorthand properties
 525 ;;;
 526
 527 (define-simple-short-hand-property list-style
 528     :value (barbar* <list-style-type>
 529                     <list-style-image>
 530                     <list-style-position>))
 531
 532 ;;; xxx these border assignments have a flaw, since "border-left: 1px"
 533 ;;; implies default values on style and color, I guess.
 534
 535 (define-simple-short-hand-property border-left
 536     :value (barbar* <border-left-width>
 537                     <border-left-style>
 538                     <border-left-color>))
 539
 540 (define-simple-short-hand-property border-right
 541     :value (barbar* <border-right-width>
 542                     <border-right-style>
 543                     <border-right-color>))
 544
 545 (define-simple-short-hand-property border-top
 546     :value (barbar* <border-top-width>
 547                     <border-top-style>
 548                     <border-top-color>))
 549
 550 (define-simple-short-hand-property border-bottom
 551     :value (barbar* <border-bottom-width>
 552                     <border-bottom-style>
 553                     <border-bottom-color>))
 554
 555 (define-simple-short-hand-property font
 556     ;; xxx CSS2: inherit
 557     :value (&* (? (barbar* <font-style> <font-variant> <font-weight>))
 558                <font-size>
 559                (? (&* <slash> <line-height>))
 560                <font-family>))
 561
 562 (define-edges-short-hand-property margin
 563     :names (margin-top margin-right margin-bottom margin-left)
 564     :value <a-margin>)
 565
 566 (define-edges-short-hand-property padding
 567     ;; xxx negative values are not allowed ...
 568     :names (padding-top padding-right padding-bottom padding-left)
 569     :value <a-padding>)
 570
 571 (define-edges-short-hand-property border-width
 572     :names (border-top-width border-right-width border-bottom-width border-left-width)
 573     :value <a-border-width>)
 574
 575 (define-edges-short-hand-property border-color
 576     :names (border-top-color border-right-color border-bottom-color border-left-color)
 577     :value <a-color>)
 578
 579 (define-edges-short-hand-property border-style
 580     :names (border-top-style border-right-style border-bottom-style border-left-style)
 581     :value <a-border-style>)
 582
 583 (define-simple-short-hand-property background
 584     ;; xxx "The 'background' property always sets all the individual
 585     ;;      background properties."
 586     :value (barbar* <background-image>
 587                     <background-repeat>
 588                     <background-attachment>
 589                     <background-position>
 590                     <background-color>))
 591
 592 ;; p/shape !!!
 593 ;; only allowed shape so far is:
 594
 595 ;; 'rect' '(' { <length> | 'auto' } { "," <length> | 'auto' }*3 ')'
 596
 597 ;; wir koennten jedoch sehr leicht auch noch union(...),
 598 ;; intersection(...), difference(...),
 599 ;; everything, nothing
 600 ;; anbieten. (Koennten wir aus Spass ja mal machen).
 601
 602
 603 ;;; ------------------------------------------------------------------------------------------
 604 ;;;  Value Cooking
 605
 606 (define-cooking display
 607     :applicable-if (not (eql (prop float) :none))
 608     :value         :block)
 609
 610 (define-cooking (background-image list-style-image)
 611     :applicable-if (stringp value)
 612     :value         (url:parse-url value))
 613
 614 #||
 615 (define-cooking font-size
 616     :applicable-if (eql @font-size :xx-small)
 617     :value         (* (expt *font-scaling-factor* -3) (interpret-length device *medium-font-size* nil)))
 618
 619 (define-cooking font-size
 620     :applicable-if (eql @font-size :x-small)
 621     :value         (* (expt *font-scaling-factor* -2) (interpret-length device *medium-font-size* nil)))
 622
 623 (define-cooking font-size
 624     :applicable-if (eql @font-size :small)
 625     :value         (* (expt *font-scaling-factor* -1) (interpret-length device *medium-font-size* nil)))
 626
 627 (define-cooking font-size
 628     :applicable-if (eql @font-size :medium)
 629     :value         (* (expt *font-scaling-factor* 0) (interpret-length device *medium-font-size* nil)))
 630
 631 (define-cooking font-size
 632     :applicable-if (eql @font-size :large)
 633     :value         (* (expt *font-scaling-factor* 1) (interpret-length device *medium-font-size* nil)))
 634
 635 (define-cooking font-size
 636     :applicable-if (eql @font-size :x-large)
 637     :value         (* (expt *font-scaling-factor* 2) (interpret-length device *medium-font-size* nil)))
 638
 639 (define-cooking font-size
 640     :applicable-if (eql @font-size :xx-large)
 641     :value         (* (expt *font-scaling-factor* 3) (interpret-length device *medium-font-size* nil)))
 642 ||#
 643
 644 (define-cooking font-size
 645     :applicable-if (eql value :smaller)
 646     :value         (round (parent-prop font-size) *font-scaling-factor*))
 647
 648 (define-cooking font-size
 649     :applicable-if (eql value :larger)
 650     :value         (round (parent-prop font-size) (/ *font-scaling-factor*)))
 651
 652 (define-cooking font-weight
 653     :applicable-if (eql value :normal)
 654     :value         400)
 655
 656 (define-cooking font-weight
 657     :applicable-if (eql value :bold)
 658     :value         700)
 659
 660 #||
 661 (define-cooking font-weight
 662     :applicable-if (eql value :bolder)
 663     :value         (min 900 (+ (parent-prop font-weight) 300)))
 664
 665 (define-cooking font-weight
 666     :applicable-if (eql value :lighter)
 667     :value         (max 100 (- (parent-prop font-weight) 300)))
 668 ||#
 669
 670 ;; XXX kludge
 671 (define-cooking font-weight
 672     :applicable-if (eql value :bolder)
 673     :value         700)
 674
 675 (define-cooking font-weight
 676     :applicable-if (eql value :lighter)
 677     :value         400)
 678
 679 (define-cooking (border-top-width border-right-width border-bottom-width border-left-width)
 680     :applicable-if (eql value :thin) :value *thin-border*)
 681
 682 (define-cooking (border-top-width border-right-width border-bottom-width border-left-width)
 683     :applicable-if (eql value :medium) :value *medium-border*)
 684
 685 (define-cooking (border-top-width border-right-width border-bottom-width border-left-width)
 686     :applicable-if (eql value :thick) :value *thick-border*)
 687
 688 (define-length-cooking (border-top-width border-right-width border-bottom-width border-left-width
 689                         letter-spacing
 690                         word-spacing
 691                         vertical-align
 692                         margin-top margin-right margin-bottom margin-left
 693                         padding-top padding-right padding-bottom padding-left
 694                         text-indent width height top right bottom left line-height
 695                         marker-offset) )
 696
 697 (define-cooking font-size
 698     :applicable-if (and (consp value)
 699                     (member (car value) '(:px :in :cm :mm :pt :pc :canvas-h-percentage :canvas-v-percentage)))
 700     :value         (new-interpret-length value device :nan pt dpi))
 701
 702 (define-cooking font-size
 703     :applicable-if (and (consp value)
 704                         (member (car value) '(:em :ex)))
 705     :value         (new-interpret-length value device (parent-prop font-size) pt dpi))
 706
 707 (define-percentage-cooking font-size
 708     :base          (parent-prop font-size))
 709
 710 #+NIL
 711 (define-cooking letter-spacing
 712     :applicable-if (eql value :normal)
 713     :value         0)
 714
 715 (define-percentage-cooking letter-spacing
 716     :base (prop font-size))
 717
 718 #||
 719 ;; this one is bogus
 720 (define-cooking vertical-align
 721     :applicable-if (percentage-p value)
 722     :value         (let ((lh (prop line-height)))
 723                      (if (and (consp lh) (eq (car lh) '*))
 724                          (* (cdr lh) (prop font-size))
 725                          lh)))
 726 ||#
 727
 728 (define-percentage-cooking vertical-align
 729     :base (prop font-size))
 730
 731 (define-cooking line-height
 732     :applicable-if (eql value :normal)
 733     :value         (cons '* 1.2))       ;xxx
 734
 735 (define-cooking line-height
 736     :applicable-if (numberp value)
 737     :value         (cons '* value))
 738
 739 (define-percentage-cooking line-height
 740     :base (prop font-size))
 741
 742 (define-cooking orig-width
 743     :applicable-if t
 744     :value         (prop width))
 745
 746
 747
 748 ;;; ------------------------------------------------------------------------------------------
 749
 750 ;;;;;;;;;;;
 751
 752 (defun p/the-border (tokens)
 753   ;;  <border-width> || <border-style> || <color>
 754   (let ((r0 (p/border-top tokens))
 755         (r1 (p/border-right tokens))
 756         (r2 (p/border-bottom tokens))
 757         (r3 (p/border-left tokens)))
 758     (and r0
 759          (progn
 760            (assert (and (eq (cdr r0) (cdr r1))
 761                         (eq (cdr r0) (cdr r2))
 762                         (eq (cdr r0) (cdr r3))
 763                         (eq (cdr r1) (cdr r2))
 764                         (eq (cdr r1) (cdr r3))
 765                         (eq (cdr r2) (cdr r3))))
 766            (cons (append (car r0) (car r1) (car r2) (car r3))
 767                  (cdr r0))))))
 768
 769 (define-simple-short-hand-property border
 770     :value <the-border>)
 771
 772 ;;;;;
 773
 774 (define-cooking border-top-width
 775     :applicable-if (eql (prop border-top-style) :none)
 776     :value         0)
 777
 778 (define-cooking border-right-width
 779     :applicable-if (eql (prop border-right-style) :none)
 780     :value         0)
 781
 782 (define-cooking border-bottom-width
 783     :applicable-if (eql (prop border-bottom-style) :none)
 784     :value         0)
 785
 786 (define-cooking border-left-width
 787     :applicable-if (eql (prop border-left-style) :none)
 788     :value         0)
 789
 790 ;;;; CSS-2 table properties
 791
 792 (define-css-property caption-side
 793     :default-value :top
 794     :value (or :top :bottom :left :right)
 795     ;; :applies-to (:table-caption)
 796     :inheritedp t
 797     ;; :media :visual
 798     )
 799
 800 (define-css-property table-layout
 801     :default-value :auto
 802     :value (or :auto :fixed)
 803     :inheritedp nil
 804     ; :applies-to (:table :inline-table)
 805     )
 806
 807 (define-css-property border-collapse
 808     :default-value :collapse
 809     :value (or :collapse :separate)
 810         ; :applies-to (:table :inline-table)
 811     :inheritedp t)
 812
 813 (define-css-property border-spacing
 814     :default-value '(0 0)
 815     :value (or (& <non-negative-length> <non-negative-length>)
 816                (mungle <non-negative-length> (lambda (x) (list x x))))
 817     :inheritedp t
 818     ;; :applies-to (:table :inline-table)
 819     )
 820
 821 (define-cooking border-spacing
 822     :applicable-if t
 823     :value (list (new-interpret-length (first value) device (prop font-size) pt dpi)
 824                  (new-interpret-length (second value) device (prop font-size) pt dpi)))
 825
 826 #+emarsden
 827 (define-css-property empty-cells
 828     :value (or :show :hide)
 829     :default-value :show
 830     ;; :applies-to (:table :inline-table)
 831     :inheritedp t)
 832
 833 #||
 834 (define-css-property speak-header
 835     :value (or :once :always)
 836     :default-value :once
 837     :inheritedp t
 838     ;; :media :aural
 839     )
 840 ||#
 841
 842 ;;; ---------------------------------------------------------------------------
 843
 844 (defun p/background-position-1 (tokens)
 845   ;;  [<percentage> | <length>]{1,2}
 846   (let ((r (p/repeated tokens 1 2 (lambda (toks)
 847                                     (or (p/percentage toks)
 848                                         (p/length toks))))))
 849     (and r
 850          (cons (let* ((v (car r))
 851                       (x (first v))
 852                       (y (or (second v) (cons :% 50))))
 853                  (cons x y))
 854                (cdr r)))))
 855
 856 (defun p/background-position-2 (tokens)
 857   ;; [top | center | bottom] || [left | center | right]
 858   ;; we treat this as:
 859   ;;   [ [ top | bottom ] [ left | center | right ]? ] |
 860   ;;   [ [ left | right ] [ top | center | bottom ]? ] |
 861   ;;   [ center [ top | bottom | left | right | center]? ]
 862   (let ((r (or
 863             (p/concat tokens
 864                       (rcurry #'p/simple-enum :top :bottom)
 865                       (rcurry #'p/maybe (rcurry #'p/simple-enum
 866                                                 :left :center :right)))
 867             (p/concat tokens
 868                       (rcurry #'p/simple-enum :left :right)
 869                       (rcurry #'p/maybe (rcurry #'p/simple-enum
 870                                                 :top :center :bottom)))
 871             (p/concat tokens
 872                       (rcurry #'p/simple-enum :center)
 873                       (rcurry #'p/maybe
 874                               (rcurry #'p/simple-enum
 875                                       :left :right :top :center :bottom))) )))
 876     (and r
 877          (let ((v (car r)))
 878            (multiple-value-bind (x y)
 879                (cond ((or (equal v '(:top :left))
 880                           (equal v '(:left :top)))
 881                       (values '(:% . 0) '(:% . 0)))
 882                      ((or (equal v '(:top nil))
 883                           (equal v '(:top :center))
 884                           (equal v '(:center :top)))
 885                       (values '(:% . 50) '(:% . 0)))
 886                      ((or (equal v '(:right :top))
 887                           (equal v '(:top :right)))
 888                       (values '(:% . 100) '(:% . 0)))
 889                      ((or (equal v '(:left nil))
 890                           (equal v '(:left :center))
 891                           (equal v '(:center :left)))
 892                       (values '(:% . 0) '(:% . 50)))
 893                      ((or (equal v '(:center nil))
 894                           (equal v '(:center :center)))
 895                       (values '(:% . 50) '(:% . 50)))
 896                      ((or (equal v '(:right nil))
 897                           (equal v '(:right :center))
 898                           (equal v '(:center :right)))
 899                       (values '(:% . 100) '(:% . 50)))
 900                      ((or (equal v '(:bottom nil))
 901                           (equal v '(:bottom :center))
 902                           (equal v '(:center :bottom)))
 903                       (values '(:% . 50) '(:% . 100)))
 904                      ((or (equal v '(:bottom :left))
 905                           (equal v '(:left :bottom)))
 906                       (values '(:% . 0) '(:% . 100)))
 907                      ((or (equal v '(:right :bottom))
 908                           (equal v '(:bottom :right)))
 909                       (values '(:% . 100) '(:% . 100))))
 910              (cons (cons x y) (cdr r)))))))
 911
 912 (defun p/a-background-position (tokens)
 913   (or (p/background-position-1 tokens)
 914       (p/background-position-2 tokens)))
 915
 916 ;;; ------------------------------------------------------------------------------------------
 917 ;;;  Code Generation
 918 ;;;
 919 )
 920
 921 (eval-when (eval compile load)
 922   (generate-slot-constants))
 923
 924 (generate-parsers)
 925 (register-parsers)
 926 (generate-setup-style)
 927 (generate-setup-style-1)
 928 (generate-setup-style-3)
 929
 930 (defmethod print-object ((object cooked-style) stream)
 931   (print-unreadable-object (object stream :type t :identity nil)
 932     (with-slots (%element) object
 933       (cond (%element
 934              (format stream "for ~A"
 935                      (element-gi %element))
 936              (loop for class in '(:before :after :first-line :first-letter) do
 937                    (when (pseudo-class-matches-p class %element)
 938                      (format stream "~(:~A~)" class))))
 939             (t
 940              (princ "anonymous" stream)) ))))
 941
 942
 943
 944 ;; $Log: css-properties.lisp,v $
 945 ;; Revision 1.9  2007-07-07 15:03:56  dlichteblau
 946 ;; Umlaute raus!
 947 ;;
 948 ;; Revision 1.8  2005/03/13 18:00:58  gbaumann
 949 ;; Gross license change
 950 ;;
 951 ;; Revision 1.7  2003/03/14 17:06:16  dan
 952 ;; replace defconstants for non-constant variables with defvar, to placate SBCL, which suffers from offensively ANSI behaviour with same
 953 ;;
 954 ;; Revision 1.6  2003/03/13 19:29:17  gilbert
 955 ;; lots of hacking
 956 ;;
 957 ;; Revision 1.5  2002/07/29 12:41:25  gilbert
 958 ;; - cooking for 'border-*-width' on '(eql (prop border-*-style) :none)'
 959 ;;   must come late.
 960 ;; - border default values are now uncooked.
 961 ;;
 962 ;; Revision 1.4  2002/07/27 18:01:47  gilbert
 963 ;; provided percentage cooking for line-height
 964 ;;
 965 ;; Revision 1.3  2002/07/24 04:10:14  gilbert
 966 ;; Whole file is now wraped into (eval-when (eval compile load) ...)
 967 ;; Fixing cold built.
 968 ;;
 969 ;; Revision 1.2  2002/07/22 10:15:44  gilbert
 970 ;; *COOKINGS* now is properly cleared.
 971 ;;
 972