[wadalabfont-kit] / lisp / tools / init.l  

Annotation of /lisp/tools/init.l

Parent Directory | Revision Log

Revision: 1.2 - (view) (download)

1 : ktanaka 1.1 ;;
2 :     ;; init.l
3 : ktanaka 1.2 ;; $Revision: 1.1 $
4 : ktanaka 1.1 ;;
5 :    
6 :     ;; ------------------------- ;;
7 :     ;; make display, screen, ... ;;
8 :     ;; ------------------------- ;;
9 :     (defun setup-display ()
10 :     (if (and (boundp 'display) (display-p display))
11 :     (cleanup-display))
12 :    
13 :     ; tanaka
14 :     (setq grid nil)
15 :     (setq display-host (get-display-host))
16 :     (or display-host (progn (format "Display unknown/n")
17 :     (funcall (function err:argument-type))))
18 :    
19 :     (setq display (open-display display-host))
20 :     (setq screen (first (display-roots display)))
21 :     (setq root (screen-root screen))
22 :    
23 :     (setq black (screen-black-pixel screen)
24 :     white (screen-white-pixel screen))
25 :    
26 :     (setq kanji-font (open-font display "k14")
27 :     ascii-font (open-font display "a14"))
28 :    
29 :     (setq colmap (screen-default-colormap screen))
30 :     (setq color-map-black (first (lookup-color colmap "black")))
31 :     (setq color-map-white (first (lookup-color colmap "white")))
32 :     (setq cursor-font (open-font display "cursor"))
33 :    
34 :     (setq roupe-cursor (create-glyph-cursor
35 :     :source-font cursor-font
36 :     :source-char 24
37 :     :mask-font cursor-font
38 :     :mask-char 25
39 :     :foreground color-map-black
40 :     :background color-map-white)
41 :     please-wait-cursor (create-glyph-cursor
42 :     :source-font cursor-font
43 :     :source-char 150
44 :     :mask-font cursor-font
45 :     :mask-char 151
46 :     :foreground color-map-black
47 :     :background color-map-white)
48 :     hair-cross-cursor (create-glyph-cursor
49 :     :source-font cursor-font
50 :     :source-char 34
51 :     :mask-font cursor-font
52 :     :mask-char 35
53 :     :foreground color-map-black
54 :     :background color-map-white))
55 :    
56 :     (setq root-blackgc (create-gcontext :drawable root
57 :     :fill-rule ':winding
58 :     :foreground black :background white
59 :     :font kanji-font))
60 :    
61 :     (setq root-whitegc (create-gcontext :drawable root
62 :     :foreground white :background black
63 :     :font kanji-font))
64 :    
65 :     (setq root-reversegc (create-gcontext :drawable root
66 :     :foreground black :background white
67 :     :font kanji-font
68 :     :function boole-c1))
69 :    
70 :     (setq root-xorgc (create-gcontext :drawable root
71 :     :function boole-eqv))
72 :    
73 :     (setq root-dashlinegc (create-gcontext :drawable root
74 :     :line-style ':double-dash
75 :     :function boole-c1))
76 :    
77 :     (setq root-saveblackgc (create-gcontext :drawable root
78 :     :foreground black
79 :     :background white
80 :     :font kanji-font))
81 :    
82 :     (setq root-savewhitegc (create-gcontext :drawable root
83 :     :foreground white
84 :     :background black
85 :     :font kanji-font))
86 :    
87 :     (setq default-depth (screen-depth screen))
88 :     )
89 :    
90 :     (defun screen-depth (scr)
91 :     (let ((alist (screen-depths scr)))
92 :     (do ((p alist (cdr p)))
93 :     ((or (null p)
94 :     (not (null (cdar p))))
95 :     (if (null p) nil (caar p)))
96 :     (comment print p))))
97 :    
98 :     (defun cleanup-display ()
99 :     (close-display display))
100 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help