View of /lisp/tools/init.l

Parent Directory

Revision Log

Initial revision

;;
;; init.l
;; $Revision: 1.1 $
;;

;; ------------------------- ;;
;; make display, screen, ... ;;
;; ------------------------- ;;
(defun setup-display ()
  (if (and (boundp 'display) (display-p display))
      (cleanup-display))

; tanaka
  (setq grid nil)
  (setq display-host (get-display-host))
  (or display-host (progn (format "Display unknown/n")
			  (funcall (function err:argument-type))))
  
  (setq display (open-display display-host))
  (setq screen (first (display-roots display)))
  (setq root (screen-root screen))
  
  (setq black (screen-black-pixel screen)
	white (screen-white-pixel screen))
  
  (setq kanji-font (open-font display "k14")
	ascii-font (open-font display "a14"))

  (setq colmap (screen-default-colormap screen))
  (setq color-map-black (first (lookup-color colmap "black")))
  (setq color-map-white (first (lookup-color colmap "white")))
  (setq cursor-font (open-font display "cursor"))
  
  (setq roupe-cursor       (create-glyph-cursor
			    :source-font cursor-font
			    :source-char 24
			    :mask-font   cursor-font
			    :mask-char   25
			    :foreground color-map-black
			    :background color-map-white)
	please-wait-cursor (create-glyph-cursor
			    :source-font cursor-font
			    :source-char 150
			    :mask-font   cursor-font
			    :mask-char   151
			    :foreground color-map-black
			    :background color-map-white)
	hair-cross-cursor  (create-glyph-cursor
			    :source-font cursor-font
			    :source-char 34
			    :mask-font   cursor-font
			    :mask-char   35
			    :foreground color-map-black
			    :background color-map-white))

  (setq root-blackgc (create-gcontext :drawable root
				      :fill-rule ':winding
				      :foreground black :background white
				      :font kanji-font))
	 
  (setq root-whitegc (create-gcontext :drawable root
				      :foreground white :background black
				      :font kanji-font))
	 
  (setq root-reversegc (create-gcontext :drawable root
				   :foreground black :background white
				   :font kanji-font
				   :function boole-c1))
  
  (setq root-xorgc (create-gcontext :drawable root
			       :function boole-eqv))

  (setq root-dashlinegc (create-gcontext :drawable root
			       :line-style ':double-dash
			       :function boole-c1))
  	 
  (setq root-saveblackgc (create-gcontext :drawable root
					  :foreground black 
					  :background white
					  :font kanji-font))
	 
  (setq root-savewhitegc (create-gcontext :drawable root
					  :foreground white 
					  :background black
					  :font kanji-font))

  (setq default-depth (screen-depth screen))
  )

(defun screen-depth (scr)
  (let ((alist (screen-depths scr)))
    (do ((p alist (cdr p)))
	((or (null p)
	     (not (null (cdar p))))
	 (if (null p) nil (caar p)))
	(comment print p))))

(defun cleanup-display ()
  (close-display display))