Changeset 3082

Show
Ignore:
Timestamp:
05/27/03 05:38:19 (6 years ago)
Author:
himi
Message:

(mw32-convert-fr-spec-to-vec):
New function.
(mw32-convert-font-legacy-strict-spec): New function.
(mw32-convert-font-request-alist): It is a reviced version
of mw32-convert-font-request-attribute. Now it deals with 'spec
key. Note that it converts 'strict-spec key with
mw32-convert-font-legacy-strict-spec.
(w32-add-font): Use mw32-convert-font-request-alist.
(w32-change-font): Fix the name of w32-change-add-font.
(logfont-from-char-and-request): New function.
(mw32-build-font-spec): Removed.
(mw32-face-attrs-weight-alist): New alist.
(mw32-convert-face-attrs-to-request): New function.
(mw32-load-lf-from-request): New function.
(create-fontset-from-request-with-spec): New function.
(change-fontset-from-request-with-spec): New function.
(create-fontset-from-request): Totally rewritten, use
create-fontset-from-request-with-spec to build a new
fontset (actually a FR).
(change-fontset-from-request): Likewise.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • work/cvs2svn/lisp/international/mw32misc.el

    r3060 r3082  
    283283 
    284284;; (:char-spec :width :height :family :weight :slant) 
    285 (defun mw32-convert-font-request-attribute (alist) 
    286   (let* ((ssslot (assq 'strict-spec alist)) 
    287          (ss (cdr ssslot)) 
    288          rs elem spec llf options key val vec) 
    289     (while (setq elem (car ss)) 
    290       (setq spec (car elem) 
    291             llf (car (cdr elem)) 
    292             options (cdr (cdr elem))) 
    293       (if (not (listp spec)) 
    294           (error "Invalid Spec %S" spec)) 
    295       (setq vec (make-vector 6 'normal)) 
     285(defun mw32-convert-fr-spec-to-vec (spec) 
     286  (if (eq spec 'any) 
     287      (make-vector 6 'any) 
     288    (let ((vec (make-vector 6 'normal)) 
     289          key val) 
    296290      (while spec 
    297291        (setq key (car spec) 
    …… 
    306300                           ((integerp val) val) 
    307301                           ((char-table-p val) val) 
     302                           ((eq val 'any) val) 
    308303                           (t (error "Invalid value for :char-spec :%S" 
    309304                                     val)))) 
    …… 
    312307               (if (not (or (numberp val) 
    313308                            (memq val '(any normal 
    314                                         condensed semi-expanded 
    315                                         expanded extra-condensed 
    316                                         extra-expanded ultra-condensed 
    317                                         ultra-expanded)))) 
     309                                            condensed semi-expanded 
     310                                            expanded extra-condensed 
     311                                            extra-expanded ultra-condensed 
     312                                            ultra-expanded)))) 
    318313                   (error "Invalid value for :width :%S" 
    319314                          val)) 
    …… 
    334329               (if (not (memq val 
    335330                              '(any normal 
    336                                 bold semi-bold 
    337                                 extra-bold light 
    338                                 semi-light ultra-light 
    339                                 extra-light))) 
     331                                    bold semi-bold 
     332                                    extra-bold light 
     333                                    semi-light ultra-light 
     334                                    extra-light))) 
    340335                   (error "Invalid value for :weight :%S" 
    341336                          val)) 
    …… 
    343338              ((eq key :slant) 
    344339               (if (not (memq val '(any normal 
    345                                     italic reverse-italic 
    346                                     oblique reverse-oblique))) 
     340                                       italic reverse-italic 
     341                                       oblique reverse-oblique))) 
    347342                   (error "Invalid value for :slant :%S" 
    348343                          val)) 
    …… 
    355350      (if (eq (aref vec 3) 'normal) 
    356351          (aset vec 3 "\\*")) 
    357       ;; check option list is assq safe. 
    358       (when (cdr (last (car options))) 
    359         (error "Option must be alist :%S" (car options))) 
    360       (setq rs (cons (cons vec (cons llf options)) rs)) 
     352      vec))) 
     353 
     354;; Note that this function must be DEPRECATED!!! 
     355(defun mw32-convert-font-legacy-strict-spec (alist) 
     356  (if (assq 'strict-spec alist) 
     357      (cons 
     358        (append 
     359         (or (assq 'spec alist) '(spec)) 
     360         (mapcar 
     361          (lambda (x) 
     362            (cons 
     363             (car x) 
     364             (cons 'strict 
     365                   (cdr x)))) 
     366          (cdr (assq 'strict-spec alist)))) 
     367        alist) 
     368    alist)) 
     369 
     370(defun mw32-convert-font-request-alist (alist) 
     371  (setq alist (mw32-convert-font-legacy-strict-spec alist)) 
     372  (let* ((sslot (assq 'spec alist)) 
     373         (ss (cdr sslot)) 
     374         rs elem spec val) 
     375    (while (setq elem (car ss)) 
     376      (setq spec (car elem) 
     377            val (cdr elem)) 
     378      (if (not (listp spec)) 
     379          (error "Invalid Spec %S" spec)) 
     380      (setq rs (cons (cons 
     381                      (mw32-convert-fr-spec-to-vec spec) 
     382                      val) 
     383                     rs)) 
    361384      (setq ss (cdr ss))) 
    362     (if rs (cons (cons 'strict-spec (nreverse rs)) 
    363                  (delq ssslot alist)) 
     385    (if rs (cons (cons 'spec (nreverse rs)) 
     386                 (delq sslot alist)) 
    364387      alist))) 
    365388 
    366389(defun w32-add-font (name alist) 
    367390  (w32-add-font-internal 
    368    name (mw32-convert-font-request-attribute alist))) 
    369  
    370 (defun w32-change-add-font (name alist) 
     391   name (mw32-convert-font-request-alist alist))) 
     392 
     393(defun w32-change-font (name alist) 
    371394  (w32-change-font-attribute-internal 
    372    name (mw32-convert-font-request-attribute alist))) 
     395   name (mw32-convert-font-request-alist alist))) 
    373396 
    374397;;; 
    …… 
    487510                    w32-font-list-cache-charset)) 
    488511        cand1)))) 
     512 
     513(defsubst logfont-from-char-and-request (c required recommended) 
     514  (run-hook-with-args-until-success 
     515   'logfont-from-request-functions 
     516   (if (< c 0) 'ascii (char-charset c)) 
     517   required recommended nil)) 
    489518  
    490519(defsubst logfont-list-from-request (required recommended &optional fontset) 
    …… 
    620649 
    621650(defun w32-logfont-list-from-request (charset required recommended fontset) 
    622   ;; fontset is used as a trivial temporal variable:-P. 
     651  ;; fontset is used as a trivial temporary variable:-P. 
    623652  (setq fontset 
    624653        (nth 3 (w32-select-logfont-from-recommended 
    …… 
    633662          (function w32-logfont-list-from-request)) 
    634663 
    635 (defun mw32-build-font-spec (charset height weight slant) 
    636   (list :char-spec charset 
    637         :height (if height 
    638                     (/ (* height 720) 96) ; pixel -> 0.1 point 
    639                   'any) 
    640         :weight weight 
    641         :slant slant)) 
     664;; new version 
     665 
     666(defvar mw32-face-attrs-weight-alist 
     667  '((normal . 400) 
     668    (bold . 700) 
     669    (ultra-bold . 800) 
     670    (semi-bold . 600) 
     671    (extra-bold . 800) 
     672    (light . 300) 
     673    (semi-light . 200) 
     674    (extra-light . 200) 
     675    (ultra-light . 200) 
     676    (extra-light . 100))) 
     677 
     678(defun mw32-convert-face-attrs-to-request (attrs) 
     679  (let (key req val) 
     680   (while attrs 
     681     (setq key (car attrs) 
     682           attrs (cdr attrs)) 
     683     (cond  
     684      ;;((eq key :width) 
     685      ;; (setq req (cons (cons 'width (car attrs)) 
     686      ;;           req))) 
     687      ((and (eq key :height) 
     688            (numberp (car attrs))) 
     689       (setq req (cons (cons 'height 
     690                             (/ (* (car attrs) 720) 96) ; pixel -> 0.1 point 
     691                             ) 
     692                       req))) 
     693      ((eq key :family) 
     694       (if (not (string= (car attrs) "*")) 
     695           (setq req (cons (cons 'family (car attrs)) 
     696                           req)))) 
     697      ((eq key :weight) 
     698       (if (setq val (assq (car attrs) 
     699                           mw32-face-attrs-weight-alist)) 
     700           (if val (setq req (cons (cons 'weight (cdr val)) req))))) 
     701      ((eq key :slant) 
     702       (if (memq (car attrs) '(italic oblique)) 
     703           (setq req (cons (cons 'italic t) 
     704                           req)))))) 
     705   req)) 
     706 
     707(defun mw32-load-lf-from-request (c attrs f required recommended option) 
     708  (setq recommended 
     709        (append recommended 
     710                (mw32-convert-face-attrs-to-request attrs))) 
     711  (cons (logfont-from-char-and-request c required recommended) 
     712        option)) 
     713 
     714(defun create-fontset-from-request-with-spec 
     715  (name spec required recommended) 
     716  "Create fontset from your request." 
     717  (w32-add-font-internal 
     718   name 
     719   `((spec 
     720      (,(mw32-convert-fr-spec-to-vec spec) 
     721       function 
     722       (lambda (c attrs f) 
     723         (mw32-load-lf-from-request 
     724          c attrs f 
     725          ',required ',recommended)) 
     726       ,(append required recommended)))))) 
     727 
     728(defun change-fontset-from-request-with-spec 
     729  (name spec required recommended) 
     730  "Create fontset from your request." 
     731  (let* ((finfo 
     732          (w32-get-font-info name)) 
     733         (fl (assq 'spec finfo)) 
     734         (vec (mw32-convert-fr-spec-to-vec spec)) 
     735         (valf 
     736          `(function 
     737            (lambda (c attrs f) 
     738              (mw32-load-lf-from-request 
     739               c attrs f 
     740               ',required ',recommended)) 
     741            ,(append required recommended))) 
     742         ts) 
     743    (if (null fl) 
     744        (setq finfo (cons (list 'spec (cons vec valf)))) 
     745      (setq ts (assoc vec (cdr fl))) 
     746      (if ts 
     747          (setcdr ts valf) 
     748        (setcdr fl (cons (cons vec valf) (cdr fl))))) 
     749    (w32-change-font-attribute-internal 
     750     name finfo))) 
    642751 
    643752(defun create-fontset-from-request 
    644753  (name required recommended) 
    645754  "Create fontset from your request." 
    646   (let ((logfont-list (logfont-list-from-request required recommended)) 
    647         (height (cdr (or (assq 'height required) 
    648                          (assq 'height recommended)))) 
    649         (spacing (cdr (or (assq 'spacing required) 
    650                           (assq 'spacing recommended)))) 
    651         (centering (cdr (or (assq 'centering required) 
    652                             (assq 'centering recommended)))) 
    653         charset logfont option font-request) 
    654     ;; build font option 
    655     (when (numberp spacing) 
    656       (setq option (cons (cons 'spacing spacing) option))) 
    657     (when (symbolp centering) 
    658       (setq option (cons (cons 'centering centering) option))) 
    659  
    660     (while logfont-list 
    661       (setq logfont (cdar logfont-list) 
    662             charset (caar logfont-list)) 
    663       (setq font-request 
    664             (cons (cons (mw32-build-font-spec charset height 'bold 'italic) 
    665                         (list logfont option)) 
    666                   font-request)) 
    667       (setq font-request 
    668             (cons (cons (mw32-build-font-spec charset height 'normal 'italic) 
    669                         (list logfont option)) 
    670                   font-request)) 
    671       (setq font-request 
    672             (cons (cons (mw32-build-font-spec charset height 'bold 'normal) 
    673                         (list logfont option)) 
    674                   font-request)) 
    675       (setq font-request 
    676             (cons (cons (mw32-build-font-spec charset height 'normal 'normal) 
    677                         (list logfont option)) 
    678                   font-request)) 
    679       (setq logfont-list (cdr logfont-list))) 
    680     (w32-add-font name (list (cons 'strict-spec font-request))))) 
     755  (create-fontset-from-request-with-spec 
     756   name 
     757   'any 
     758   required recommended)) 
    681759 
    682760(defun change-fontset-from-request 
    683761  (name required recommended &optional property) 
    684   "Change fontset from your request." 
    685   (let ((weight 'normal) 
    686         (slant 'normal) 
    687         (height (cdr (or (assq 'height required) 
    688                          (assq 'height recommended)))) 
    689         (spacing (cdr (or (assq 'spacing required) 
    690                           (assq 'spacing recommended)))) 
    691         (centering (cdr (or (assq 'centering required) 
    692                             (assq 'centering recommended)))) 
    693         (fr-old (cdr (assq 'strict-spec (w32-get-font-info name)))) 
    694         (fr-new (logfont-list-from-request required recommended)) 
    695         charset logfont spec option fr-cur elem) 
    696     ;; build spec-vec 
    697     (when (memq property '(1 3)) 
    698       (setq weight 'bold)) 
    699     (when (memq property '(2 3)) 
    700       (setq slant 'italic)) 
    701  
    702     ;; build font option 
    703     (when (numberp spacing) 
    704       (setq option (cons (cons 'spacing spacing) option))) 
    705     (when (symbolp centering) 
    706       (setq option (cons (cons 'centering centering) option))) 
    707     ;; 
    708     (while fr-new 
    709       (setq charset (caar fr-new)) 
    710       (setq logfont (cdar fr-new)) 
    711       (setq spec (mw32-build-font-spec charset height weight slant)) 
    712       (setq fr-cur 
    713             (car (cdr (assq 'strict-spec 
    714                             (mw32-convert-font-request-attribute  
    715                              (list (list 'strict-spec 
    716                                          (list spec logfont option)))))))) 
    717       (setq elem (assoc (car fr-cur) fr-old)) 
    718       (if elem 
    719           (setcdr elem (cdr fr-cur)) ; if exist, modify it. 
    720         (setq fr-old 
    721               (append fr-old (list fr-cur)))) ; if not exist, append 
    722                                               ; it at the tail of the 
    723                                               ; list. 
    724       (setq fr-new (cdr fr-new))) 
    725     (w32-change-font-attribute-internal 
    726      name (list (cons 'strict-spec fr-old))))) 
    727  
    728  
    729  
     762  "Create fontset from your request." 
     763  (let ((spec 
     764         (copy-sequence 
     765          '(:char-spec any 
     766            :width any 
     767            :height any 
     768            :family any 
     769            :weight any 
     770            :slant any)))) 
     771    (if (memq property '(1 3)) 
     772        (plist-put spec :weight 'bold)) 
     773    (if (memq property '(2 4)) 
     774        (plist-put spec :slant 'italic)) 
     775    (change-fontset-from-request-with-spec 
     776     name spec required recommended))) 
    730777 
    731778;;;;;