CLX

• 環境: FreeBSD 4.9R + CMUCL 18e + CLX

CLX な Hello, World

(defpackage :lesson.clx
  (:use :common-lisp :xlib)
  (:nicknames :lesson)
  (:export :hello-world))
(in-package :lesson.clx)

(defun hello-world (&rest args
            &key (host "localhost") (font "fixed")
            &aux display (abort? t))
  (labels ((eventloop (display gcontext)
         (event-case (display :discard-p t :force-output-p t)
               (:exposure (window)
         (clear-area window)
         (draw-glyphs window gcontext 50 80 ";; Welcome to CLX World")
         (draw-glyphs window gcontext 50 100 "(Exit) ; click mouse right button")
         nil)
           (:button-release (code)
         (if (eql code 3) t nil))))
       (main ()
         (setq display (open-display host))
         (let* ((screen (display-default-screen display))
            (black (screen-black-pixel screen))
            (white (screen-white-pixel screen))
            (font (open-font display font))
            (width  320)
            (height 240)
            (x (truncate (- (screen-width screen) width) 2))
            (y (truncate (- (screen-height screen) height) 2))
            (window (create-window :parent (screen-root screen)
                       :x x :y y :width width :height height
                       :background black
                       :border white
                       :border-width 1
                       :colormap (screen-default-colormap screen)
                       :bit-gravity :center
                       :event-mask (make-event-mask
                            :key-press :key-release
                            :button-press :button-release
                            :exposure  :pointer-motion)))
            (gcontext (create-gcontext :drawable window
                           :background black
                           :foreground white
                           :font font)))
           ;; Set window manager hints
           (set-wm-properties window
                  :name 'helloworld
                  :icon-name "helloworld"
                  :resource-name "helloworld"
                  :resource-class 'helloworld
                  :command (list* 'helloworld host args)
                  :x x :y y :width width :height height
                  :min-width width :min-height height
                  :input :off :initial-state :normal)
           (map-window window)        ; Map the window
           ;; Handle events
           (eventloop display gcontext)
           (setq abort? nil))))
    (unwind-protect
     (main)
      (when display (close-display display :abort abort?)))))