home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / epoch / tek-epoch-stuff / tek-style-utils.el < prev    next >
Encoding:
Text File  |  1991-11-20  |  18.2 KB  |  508 lines
  1. ;*****************************************************************************
  2. ;
  3. ; Filename:    tek-style-utils.el
  4. ;
  5. ; Copyright (C) 1991  Ken Wood
  6. ;
  7. ; This program is free software; you can redistribute it and/or modify
  8. ; it under the terms of the GNU General Public License as published by
  9. ; the Free Software Foundation; either version 1, or (at your option)
  10. ; any later version.
  11. ;
  12. ; This program is distributed in the hope that it will be useful,
  13. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ; GNU General Public License for more details.
  16. ;
  17. ; You should have received a copy of the GNU General Public License
  18. ; along with this program; if not, write to the Free Software
  19. ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. ;
  21. ; Author:        Ken Wood, <kwood@austek.oz.au>
  22. ; Organisation:        Austek Microsystems Pty Ltd, Australia.
  23. ; Released with permission from Austek Microsystems.
  24. ;
  25. ; Description:    Set up some default fonts for highlighting etc, and
  26. ;        define a function for building styles from default
  27. ;        option values and X11 resource defaults.
  28. ;
  29. ; IMPORTANT:    Check that the variable tek-highlight-use-attributes is
  30. ;        set correctly (see below) before attempting to use this
  31. ;        package.
  32. ;
  33. ; When loaded, this package attempts to define 3 non-proportional fonts
  34. ; which match the default minibuffer font in with and height: a non-bold
  35. ; italic font, a bold italic font and a bold upright font.
  36. ; 
  37. ; A function for defining and modifying attribute styles based on X
  38. ; resources is also provided for use by the other packages. You may
  39. ; modify the these styles by setting X11 resources (usually in your
  40. ; .Xdefaults file). Up to 9 options may be specified for each style.
  41. ; Sensible defaults are used for any options that you do not specify.
  42. ; The options are represented by the following X11 resources:
  43. ; 
  44. ;     Emacs.STYLE-NAME.style-font: Font.
  45. ; 
  46. ;     Emacs.STYLE-NAME.style-foreground: Foreground color.
  47. ; 
  48. ;     Emacs.STYLE-NAME.style-background: Background color.
  49. ; 
  50. ;     Emacs.STYLE-NAME.style-cursor-foreground: Cursor foreground color.
  51. ; 
  52. ;     Emacs.STYLE-NAME.style-cursor-background: Cursor background color.
  53. ; 
  54. ;     Emacs.STYLE-NAME.style-underline: Underline color.
  55. ; 
  56. ;     Emacs.STYLE-NAME.style-stipple: Stipple pattern.
  57. ; 
  58. ;     Emacs.STYLE-NAME.style-cursor-stipple: Stipple pattern.
  59. ; 
  60. ;     Emacs.STYLE-NAME.style-background-stipple: Stipple pattern.
  61. ; 
  62. ; The values of STYLE-NAME currently used are:
  63. ; 
  64. ;     motion: Mouse drag regions.
  65. ; 
  66. ;     src-comment: Comments in source code.
  67. ; 
  68. ;     info: Info browser buttons.
  69. ; 
  70. ;     VM-from: From: lines in VM.
  71. ; 
  72. ;     VM-subject: Subject: lines in VM.
  73. ; 
  74. ;     gnus-from: From: lines in GNUS.
  75. ; 
  76. ;     gnus-subject: Subject: lines in GNUS.
  77. ; 
  78. ;     mh-e-from: From: lines in mh-e.
  79. ; 
  80. ;     mh-e-subject: Subject: lines in mh-e.
  81. ; 
  82. ;     manual-seealso: "See Also" sections in man pages.
  83. ; 
  84. ;     manual-usersupplied: User supplied options in man pages.
  85. ; 
  86. ;     manual-heading: Fixed options in man pages. These may be shown
  87. ;     in the default font depending on your implementation of the
  88. ;     "man" program.
  89. ; 
  90. ; The above X11 resources must be loaded before you start up epoch, in
  91. ; order for them to take effect.
  92. ;
  93. ; Note: the stipple options have not been tested and I don't really understand
  94. ; stipple patterns, so there may be some problems here.
  95. ; 
  96. ;*****************************************************************************
  97.  
  98. ; $Id: tek-style-utils.el,v 1.6 1991/11/21 03:20:58 kwood Exp $
  99.  
  100. (provide 'tek-style-utils)
  101.  
  102. (defvar tek-highlight-use-attributes t
  103.   "\
  104. If non-nil, then do highlighting as for Epoch version 3 - using
  105. attributes with the style attached to the attribute. Otherwise do it
  106. as for Epoch version 4 - using the style directly.")
  107.  
  108. (defvar tek-default-font nil
  109.   "\
  110. Default font used in the minibuffer. This font is the basis for a
  111. number of special fonts used for highlighting in various places.")
  112.  
  113. (defvar tek-italic-fixed-font nil
  114.   "\
  115. A non-bold italic or oblique fixed-width font, as similar as possible
  116. to the default minibuffer font, or nil if there are no such fonts.")
  117.  
  118. (defvar tek-italic-bold-fixed-font nil
  119.   "\
  120. A bold italic or oblique fixed-width font, as similar as possible to
  121. the default minibuffer font, or nil if there is no such font.")
  122.  
  123. (defvar tek-bold-fixed-font nil
  124.   "\
  125. A bold roman (upright) fixed-width font, as similar as possible to the
  126. default minibuffer font, or nil if there is no such font.")
  127.  
  128. ;
  129. ; Now, search for & load some commonly needed fonts.
  130. ;
  131. (let (
  132.       ; Variables to hold default font information
  133.       default-font-info
  134.       default-font-name
  135.       default-font-height
  136.       default-font-width
  137.       ; String specifying the required font width.
  138.       font-width
  139.       ;
  140.       ; Variables to hold the possible values of style attributes to try
  141.       ;
  142.       height-try-list
  143.       ; List of font weights to try for bold fonts.
  144.       (bold-weight-try-list (list "-bold" "-demibold"))
  145.       ; List of slant options to try for italic fonts.
  146.       (slant-try-list (list "-i" "-o"))
  147.       ; List of spacing options to try.
  148.       (spacing-try-list (list "-m" "-c"))
  149.       )
  150.   ; Get details of current default font for the minibuffer
  151.   (setq default-font-info (font nil (minibuf-screen)))
  152.   (setq default-font-name (car default-font-info))
  153.   (setq default-font-width (cadr default-font-info))
  154.   (setq default-font-height (cadr (cdr default-font-info)))
  155.   ; Convert the font-width to a string, since it will be used
  156.   ; directly. Width must be multiplied by 10 first.
  157.   (setq font-width
  158.     (concat "-" (int-to-string (* default-font-width 10))))
  159.   ; Generate a list of font height strings to try for fixed-width fonts
  160.   ; from the default font height.
  161.   (setq height-try-list
  162.     (list (concat "-" (int-to-string default-font-height))
  163.           (concat "-" (int-to-string (1+ default-font-height)))
  164.           (concat "-" (int-to-string (1- default-font-height)))))
  165.   ;
  166.   ; First of all, record the default font.
  167.   (setq tek-default-font default-font-name)
  168.   ;
  169.   ;
  170.   ; Now, try to find an italic font similar to the minibuffer font.
  171.   ; From most preferred to least preferred, we'd like the
  172.   ; following options:
  173.   ;    1) monospaced (m), then character spacing (c).
  174.   ;     2) italic (i), then oblique (o).
  175.   ;    3) same height, then 1 pixel taller, then 1 pixel shorter.
  176.   (setq tek-italic-fixed-font
  177.     (let (
  178.           ; Variable to hold the font name currently being tried
  179.           font-try-name
  180.           ; Font finally selected, nil if none
  181.           (font-try-val nil)
  182.           ; Loop variables
  183.           (current-height-list height-try-list)
  184.           current-slant-list
  185.           current-spacing-list
  186.           )
  187.       ; Loop through the height options
  188.       (while (and (not font-try-val) current-height-list)
  189.         ; Set up the list of slant options
  190.         (setq current-slant-list slant-try-list)
  191.         ; Loop through the slant options
  192.         (while (and (not font-try-val) current-slant-list)
  193.           ; Set up the list of spacing options
  194.           (setq current-spacing-list spacing-try-list)
  195.           ; Loop through the spacing options
  196.           (while (and (not font-try-val) current-spacing-list)
  197.         (setq font-try-name
  198.               (concat "-*-*-medium"
  199.                   (car current-slant-list)
  200.                   "-*-*"
  201.                   (car current-height-list)
  202.                   "-*-*-*"
  203.                   (car current-spacing-list)
  204.                   font-width
  205.                   "-*-*"))
  206.         (setq font-try-val (get-font font-try-name))
  207.         ; Remove the first element from the spacing list
  208.         (setq current-spacing-list (cdr current-spacing-list))
  209.         ) ; end spacing loop
  210.           ; Remove the first element from the slant list
  211.           (setq current-slant-list (cdr current-slant-list))
  212.           ) ; end slant loop
  213.         ; Remove the first element from the height list
  214.         (setq current-height-list (cdr current-height-list))
  215.         ) ; end height try list
  216.       ; Check to see if we found a suitable font and return it or nil.
  217.       (if font-try-val
  218.           font-try-name
  219.         nil)))
  220.   ;
  221.   ; Now, try to find a bold italic font similar to the minibuffer font.
  222.   ; From most preferred to least preferred, we'd like the following
  223.   ; options:
  224.   ;    1) monospaced (m), then character spacing (c).
  225.   ;    2) italic (i), then oblique (o).
  226.   ;    3) bold, then demibold.
  227.   ;    4) same height, then 1 pixel taller, then 1 pixel shorter.
  228.   (setq tek-italic-bold-fixed-font
  229.     (let (
  230.           ; Variable to hold the font name currently being tried
  231.           font-try-name
  232.           ; Font finally selected, nil if none
  233.           (font-try-val nil)
  234.           ; Loop variables
  235.           (current-height-list height-try-list)
  236.           current-weight-list
  237.           current-slant-list
  238.           current-spacing-list
  239.           )
  240.       ; Loop through the height options
  241.       (while (and (not font-try-val) current-height-list)
  242.         ; Set up the list of weight options
  243.         (setq current-weight-list bold-weight-try-list)
  244.         ; Loop through the weight options
  245.         (while (and (not font-try-val) current-weight-list)
  246.           ; Set up the list of slant options
  247.           (setq current-slant-list slant-try-list)
  248.           ; Loop through the slant options
  249.           (while (and (not font-try-val) current-slant-list)
  250.         ; Set up the list of spacing options
  251.         (setq current-spacing-list spacing-try-list)
  252.         ; Loop through the spacing options
  253.         (while (and (not font-try-val) current-spacing-list)
  254.           (setq font-try-name
  255.             (concat "-*-*"
  256.                 (car current-weight-list)
  257.                 (car current-slant-list)
  258.                 "-*-*"
  259.                 (car current-height-list)
  260.                 "-*-*-*"
  261.                 (car current-spacing-list)
  262.                 font-width
  263.                 "-*-*"))
  264.           (setq font-try-val (get-font font-try-name))
  265.           ; Remove the first element from the spacing list
  266.           (setq current-spacing-list (cdr current-spacing-list))
  267.           ) ; end spacing loop
  268.         (setq font-try-val (get-font font-try-name))
  269.         ; Remove the first element from the slant list
  270.         (setq current-slant-list (cdr current-slant-list))
  271.         ) ; end slant loop
  272.           ; Remove the first element from the weight list
  273.           (setq current-weight-list (cdr current-weight-list))
  274.           ) ; end weight loop
  275.         ; Remove the first element from the height list
  276.         (setq current-height-list (cdr current-height-list))
  277.         ) ; end height try list
  278.       ; Check to see if we found a suitable font and return it or nil.
  279.       (if font-try-val
  280.           font-try-name
  281.         nil)))
  282.   ; Now, try to find a bold fixed font similar to the minibuffer font.
  283.   ; From most preferred to least preferred, we'd like the following
  284.   ; options:
  285.   ;    1) monospaced (m), then character spacing (c).
  286.   ;    2) bold, then demibold.
  287.   ;    3) same height, then 1 pixel taller, then 1 pixel shorter.
  288.   (setq tek-bold-fixed-font
  289.     (let (
  290.           ; Variable to hold the font name currently being tried
  291.           font-try-name
  292.           ; Font finally selected, nil if none
  293.           (font-try-val nil)
  294.           ; Loop variables
  295.           (current-height-list height-try-list)
  296.           current-weight-list
  297.           current-spacing-list
  298.           )
  299.       ; First of all, just try appending "bold" to the current font
  300.       ; name. This will work with some aliases, such as "6x13".
  301.       (setq font-try-name (concat default-font-name "bold"))
  302.       (setq font-try-val (get-font font-try-name))
  303.       ; If the above fails, loop through the normal options as usual.
  304.       ; Loop through the height options
  305.       (while (and (not font-try-val) current-height-list)
  306.         ; Set up the list of weight options
  307.         (setq current-weight-list bold-weight-try-list)
  308.         ; Loop through the weight options
  309.         (while (and (not font-try-val) current-weight-list)
  310.           ; Set up the list of spacing options
  311.           (setq current-spacing-list spacing-try-list)
  312.           ; Loop through the spacing options
  313.           (while (and (not font-try-val) current-spacing-list)
  314.         (setq font-try-name
  315.               (concat "-*-*"
  316.                   (car current-weight-list)
  317.                   "-r-*-*"
  318.                   (car current-height-list)
  319.                   "-*-*-*"
  320.                   (car current-spacing-list)
  321.                   font-width
  322.                   "-*-*"))
  323.         (setq font-try-val (get-font font-try-name))
  324.         ; Remove the first element from the spacing list
  325.         (setq current-spacing-list (cdr current-spacing-list))
  326.         ) ; end spacing loop
  327.           ; Remove the first element from the weight list
  328.           (setq current-weight-list (cdr current-weight-list))
  329.           ) ; end weight loop
  330.         ; Remove the first element from the height list
  331.         (setq current-height-list (cdr current-height-list))
  332.         ) ; end height try list
  333.       ; Check to see if we found a suitable font and return it or nil.
  334.       (if font-try-val
  335.           font-try-name
  336.         nil)))
  337.   )
  338.  
  339.  
  340. ; Define the prefix to be use when looking for X resources
  341. (defvar tek-resource-prefix "Emacs"
  342.   "\
  343. String to be prepended to resource names prior to looking up their
  344. value.")
  345.  
  346.  
  347. ; Define a function to initialise a style
  348. (defun tek-build-style (style-name
  349.             &optional package-style
  350.             &optional default-style-font
  351.             &optional default-style-foreground
  352.             &optional default-style-background
  353.             &optional default-style-cursor-foreground
  354.             &optional default-style-cursor-background
  355.             &optional default-style-underline
  356.             &optional default-style-stipple
  357.             &optional default-style-cursor-stipple
  358.             &optional default-style-background-stipple)
  359.   "\
  360. Return a style object, with values set as specified by the X11
  361. resources for STYLE-NAME, a string. If optional PACKAGE-STYLE is not
  362. given or nil, then create a new style.
  363.  
  364. There are 9 style fields which may be specified for the package: font,
  365. foreground, background, cursor-foreground, cursor-background,
  366. underline, stipple, cursor-stipple and background-stipple. The value
  367. of `tek-resource-prefix' is prepended to the package name,
  368. before looking up the value of the resource. Thus, the possible
  369. resources that may be specified are:
  370.  
  371. RESOURCE.STYLE-NAME.style-font
  372. RESOURCE.STYLE-NAME.style-foreground
  373. RESOURCE.STYLE-NAME.style-background
  374. RESOURCE.STYLE-NAME.style-cursor-foreground
  375. RESOURCE.STYLE-NAME.style-cursor-background
  376. RESOURCE.STYLE-NAME.style-underline
  377. RESOURCE.STYLE-NAME.style-stipple
  378. RESOURCE.STYLE-NAME.style-cursor-stipple
  379. RESOURCE.STYLE-NAME.style-background-stipple
  380.  
  381. See make-style and the style-* and set-style-* functions for details
  382. of style options.
  383.  
  384. This function also takes 9 optional arguments: FONT, FOREGROUND,
  385. BACKGROUND, CURSOR-FOREGROUND, CURSOR-BACKGROUND, UNDERLINE, STIPPLE,
  386. CURSOR-STIPPLE and BACKGROUND-STIPPLE. These are the default values to
  387. use no X11 resources for the package are defined. If any X11 resources
  388. are not defined, the default value will be used to specify that style
  389. option.
  390.  
  391. If any style option is not specified by either X11 resource and the
  392. corresponding default value is not specified or is nil, then that
  393. style field will not be set."
  394.   (let (
  395.     ; Use a local variable for the package style.
  396.     (new-package-style package-style)
  397.     ; Names of the specified X11 resources.
  398.     (font-resource-name
  399.      (concat tek-resource-prefix "."
  400.          style-name ".style-font"))
  401.     (foreground-resource-name
  402.      (concat tek-resource-prefix "."
  403.          style-name ".style-foreground"))
  404.     (background-resource-name
  405.      (concat tek-resource-prefix "."
  406.          style-name ".style-background"))
  407.     (cursor-foreground-resource-name
  408.      (concat tek-resource-prefix "."
  409.          style-name ".style-cursor-foreground"))
  410.     (cursor-background-resource-name
  411.      (concat tek-resource-prefix "."
  412.          style-name ".style-cursor-background"))
  413.     (underline-resource-name
  414.      (concat tek-resource-prefix "."
  415.          style-name ".style-underline"))
  416.     (stipple-resource-name
  417.      (concat tek-resource-prefix "."
  418.          style-name ".style-stipple"))
  419.     (cursor-stipple-resource-name
  420.      (concat tek-resource-prefix "."
  421.          style-name ".style-cursor-stipple"))
  422.     (background-stipple-resource-name
  423.      (concat tek-resource-prefix "."
  424.          style-name ".style-backgound-stipple"))
  425.     ; Calculated style field values.
  426.     (package-font nil)
  427.     (package-foreground nil)
  428.     (package-background nil)
  429.     (package-cursor-foreground nil)
  430.     (package-cursor-background nil)
  431.     (package-underline nil)
  432.     (package-stipple nil)
  433.     (package-cursor-stipple nil)
  434.     (package-background-stipple nil)
  435.     )
  436.     ; Attempt to find the required settings in the X11 resources.
  437.     (setq package-font
  438.       (get-default font-resource-name))
  439.     (setq package-foreground
  440.       (get-default foreground-resource-name))
  441.     (setq package-background
  442.       (get-default background-resource-name))
  443.     (setq package-cursor-foreground
  444.       (get-default cursor-foreground-resource-name))
  445.     (setq package-cursor-background
  446.       (get-default cursor-background-resource-name))
  447.     (setq package-underline
  448.       (get-default underline-resource-name))
  449.     (setq package-stipple
  450.       (get-default stipple-resource-name))
  451.     (setq package-cursor-stipple
  452.       (get-default cursor-stipple-resource-name))
  453.     (setq package-background-stipple
  454.       (get-default background-stipple-resource-name))
  455.     ; If any of the X11 resources were not defined, use the defaults.
  456.     (if (not package-font)
  457.     (setq package-font default-style-font))
  458.     (if (not package-foreground)
  459.     (setq package-foreground default-style-foreground))
  460.     (if (not package-background)
  461.     (setq package-background default-style-background))
  462.     (if (not package-cursor-foreground)
  463.     (setq package-cursor-foreground default-style-cursor-foreground))
  464.     (if (not package-cursor-background)
  465.     (setq package-cursor-background default-style-cursor-background))
  466.     (if (not package-underline)
  467.     (setq package-underline default-style-underline))
  468.     (if (not package-stipple)
  469.     (setq package-stipple default-style-stipple))
  470.     (if (not package-cursor-stipple)
  471.     (setq package-cursor-stipple default-style-cursor-stipple))
  472.     (if (not package-background-stipple)
  473.     (setq package-background-stipple default-style-background-stipple))
  474.     ; Create a new style if necessary.
  475.     (if (not new-package-style)
  476.     (setq new-package-style (make-style)))
  477.     ; Set each of the style fields if a value is defined for it.
  478.     (if package-font
  479.     (set-style-font new-package-style
  480.             package-font))
  481.     (if package-foreground
  482.     (set-style-foreground new-package-style
  483.                   package-foreground))
  484.     (if package-background
  485.     (set-style-background new-package-style
  486.                   package-background))
  487.     (if package-cursor-foreground
  488.     (set-style-cursor-foreground new-package-style
  489.                      package-cursor-foreground))
  490.     (if package-background
  491.     (set-style-background new-package-style
  492.                   package-background))
  493.     (if package-underline
  494.     (set-style-underline new-package-style
  495.                  package-underline))
  496.     (if package-stipple
  497.     (set-style-stipple new-package-style
  498.                package-stipple))
  499.     (if package-cursor-stipple
  500.     (set-style-cursor-stipple new-package-style
  501.                   package-cursor-stipple))
  502.     (if package-background-stipple
  503.     (set-style-background-stipple new-package-style
  504.                       package-background-stipple))
  505.     ; return the style
  506.     new-package-style
  507.     ))
  508.