; .EnTete "Le-Lisp (c) version 15.2" " " "Gestion du bitmap virtuel"
; .EnPied " " "%" " "
; .Chapitre 8 "Gestion du Bitmap"
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA.  "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA                 "
; .Centre "*****************************************************************"

; .Centre "$Header: virbitmap.ll,v 4.10 89/01/11 17:54:11 nuyens Exp $"

(unless (>= (version) 15.2)
        (error 'load 'erricf 'virbitmap))

(add-feature 'virbitmap)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                 GLOBALES                                    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(unless (boundp 'errnotadisplay)
        (defvar errnotadisplay
          #- #:system:foreign-language "n'est pas un dispositif d'affichage"
          #+ #:system:foreign-language "not a display"))

(unless (boundp 'errnotawindow)
        (defvar errnotawindow
          #- #:system:foreign-language "l'argument n'est pas une fene^tre"
          #+ #:system:foreign-language "not a window"))

(unless (boundp 'errnotawindowtype)
        (defvar errnotawindowtype
        #- #:system:foreign-language "l'argument n'est pas un type de fene^tre"
        #+ #:system:foreign-language "not a window type"))

(unless (boundp 'errnotabitmap)
        (defvar errnotabitmap
          #- #:system:foreign-language "l'argument n'est pas une ico^ne"
          #+ #:system:foreign-language "not a bitmap"))

(unless (boundp 'errnotamenu)
        (defvar errnotamenu
          #- #:system:foreign-language "l'argument n'est pas un menu"
          #+ #:system:foreign-language "not a menu"))

(unless (boundp 'errnotacolor)
        (defvar errnotacolor
          #- #:system:foreign-language "l'argument n'est pas une couleur"
          #+ #:system:foreign-language "not a color"))

(unless (boundp 'errnotamutable)
        (defvar errnotamutable
          #- #:system:foreign-language
          "l'argument n'est pas une couleur modifiable"
          #+ #:system:foreign-language "not a mutable color"))

(unless (boundp 'errbitmapinuse)
        (defvar errbitmapinuse
        #- #:system:foreign-language "pattern utilise' commme motif ou curseur"
        #+ #:system:foreign-language "bitmap used as a pattern or a cursor"))

(unless (boundp 'errnotasaveddisplay)
        (defvar errnotasaveddisplay
        #- #:system:foreign-language "pas un display sauve par bitsave"
        #+ #:system:foreign-language "not a bitsaved display"))

(unless (boundp '#:sys-package:bitmap) (defvar #:sys-package:bitmap))
(unless (boundp '#:bitmap:name) (defvar #:bitmap:name))

(unless (boundp '#:display:default-bitmap)
        (defvar #:display:default-bitmap 'bvtty))

(unless (boundp '#:display:all-bitmaps)     (defvar #:display:all-bitmaps))
(unless (boundp '#:display:all-displays)    (defvar #:display:all-displays))
(unless (boundp '#:display:current-display) (defvar #:display:current-display))
(unless (boundp '#:window:prologuep)        (defvar #:window:prologuep))
(unless (boundp '#:window:all-windows)      (defvar #:window:all-windows))
(unless (boundp '#:window:current-window)   (defvar #:window:current-window))

(unless (boundp '#:window:current-keyboard-focus-window)
        (defvar #:window:current-keyboard-focus-window))

(unless (boundp '#:graph-env:current-graph-env)
        (defvar #:graph-env:current-graph-env))

(unless (boundp '#:graph-env:main-graph-env)
        (defvar #:graph-env:main-graph-env))

(unless (boundp '#:mode:set)         (defvar #:mode:set 3))
(unless (boundp '#:mode:or)          (defvar #:mode:or 7))
(unless (boundp '#:mode:xor)         (defvar #:mode:xor 6))
(unless (boundp '#:mode:not)         (defvar #:mode:not 12))
(unless (boundp '#:clip:x)           (defvar #:clip:x 0))
(unless (boundp '#:clip:y)           (defvar #:clip:y 0))
(unless (boundp '#:clip:w)           (defvar #:clip:w 0))
(unless (boundp '#:clip:h)           (defvar #:clip:h 0))
(unless (boundp '#:graph-env:vx)     (defvar #:graph-env:vx #[0 0 0 0 0]))
(unless (boundp '#:graph-env:vy)     (defvar #:graph-env:vy #[0 0 0 0 0]))
(unless (boundp '#:event:x)          (defvar #:event:x))
(unless (boundp '#:event:y)          (defvar #:event:y))
(unless (boundp '#:event:code)       (defvar #:event:code))
(unless (boundp '#:event:move-event) (defvar #:event:move-event 256))
(unless (boundp '#:event:click-event)(defvar #:event:click-event 257))
(unless (boundp '#:mouse:event-mode) (defvar #:mouse:event-mode 0))
(unless (boundp '#:mouse:x)          (defvar #:mouse:x))
(unless (boundp '#:mouse:y)          (defvar #:mouse:y))
(unless (boundp '#:mouse:state)      (defvar #:mouse:state))
(unless (boundp '#:check-window:x) (defvar #:check-window:x))
(unless (boundp '#:check-window:y) (defvar #:check-window:y))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                       Les fonctions de verification 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de #:display:check-display (fct display)
    (ifn (memq display #:display:all-displays)
         (error fct errnotadisplay display)
         t))

(de #:window:check-window (fct display window)
    (ifn display
         (error fct errnotadisplay display)
         (ifn (memq window (#:display:windows display))
              (error fct errnotawindow window)
              t)))

(de #:window:check-windows (fct win1 win2)
    (ifn (eq (#:window:display win1) (#:window:display win2))
         (error fct errnotadisplay  (#:window:display win1))
         t))

(de #:bitmap:check-bitmap (fct display bitmap)
    (ifn display
         (error fct errnotadisplay display)
         t))

(de #:bitmap:check-bitmaps (fct b1 b2)
    (ifn (eq (#:bitmap:display b1) (#:bitmap:display b2))
         (error fct errnotadisplay (#:bitmap:display b1))
         t))

(de #:menu:check-menu (fct display menu)
    (ifn display
         (error fct errnotadisplay display)
         (ifn (memq menu (#:display:menus display))
              (error fct errnotamenu menu)
              t)))

(de #:color:check-color (fct display color)
    (ifn display
         (error fct errnotadisplay display)
         (ifn (memq color (#:display:colors display))
              (error fct errnotacolor color)
              t)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                             CHARGEMENT                                      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de inibitmap bitmap
    (let ((name (symbol () (cond ((consp bitmap) (car bitmap))
                                 ((getenv "BITMAP"))
                                 (t #:display:default-bitmap)))))
      (setq #:bitmap:name name)
      (unless (cassq name #:display:all-bitmaps)
              (let ((file (catenate #:system:virbitmap-directory
                                    name
                                    #:system:lelisp-extension)))
                (if (probefile file)
                    (loadfile file t)
                  (error 'inibitmap errfile file)))
              (setq #:display:all-bitmaps
                    (acons name #:sys-package:bitmap #:display:all-bitmaps)))
      name))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                  DISPLAY                                    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct display
  name
  package
  device
  xmax
  ymax 
  eventmode
  prologuep
  keyboard-focus-window
  window
  graph-env
  root-window
  main-graph-env
  background
  foreground
  windows
  bitmaps
  menus
  colors          ; liste des objets couleurs valides
  font-names      ; Alist (string . fix) donnant le nom des polices
  pattern-bitmaps ; liste des bitmaps associe's aux motifs
  cursor-bitmaps  ; liste de (bitmap mask hotx hoty) associe's aux curseurs
  extend)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de bitprologue args
    (let ((name (when args (nextl args)))
          (device (when args (nextl args))))
      (when #:display:all-bitmaps
            (unless name (setq name (caar #:display:all-bitmaps)))
            (let* ((package (cassq name #:display:all-bitmaps))
                   (display (if (and package
                                     (getfn1 package 'make)
                                     (subtypep package 'display))
                                (new package)
                              (new 'display))))
              (#:display:name display name)
              (#:display:package display package)
              (#:display:device display device)
              (send 'bitprologue display)
              (newl #:display:all-displays display)
              (#:display:prologuep display t)
              (unless (current-display) (current-display display))
              display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; (bitmap-save) (bitmap-save <displays>) (bitmap-save t)
; sauvegarde les fenetres, menus, icones, polices, motifs, couleurs et
; curseurs du display courant (sans argument), de tous les displays ouverts
; (si l'arg vaut T) de la liste de displays argument sinon)
; retourne en valeur la liste des displays sauves
; dans un etat tel que l'on peut la passer
; a la fonction bitrestore qui restore l'e'tat sauve.
; Utilise' typiquement aux alentour d'un save-core...
; Le display courant est retourne dans le car de la liste
; ce qui le rerendra courant au restore (sauf si un autre display
; non sauve est devenu courant pendant ce temps)

(de bitmap-save &nobind
    (let ((displays (cond ((eq (arg) 0) (list (current-display)))
                          ((eq (arg 0) t)
                           (ifn (current-display)
                                #:display:all-displays
                                (cons (current-display)
                                      (delq (current-display)
                                            #:display:all-displays))))
                          (t (arg 0)))))
      (mapc ':save-a-display displays)
      displays))

(de :save-a-display (display)
    (let ((saved-windows (append (#:display:windows display) ()))
          (saved-bitmaps
           (mapcar (lambda (i)
                     (list i
                           (#:bitmap:w i) (#:bitmap:h i)
                           (#:bitmap:bits i)))
                   (#:display:bitmaps display)))
          (saved-menus (append (#:display:menus display) ()))
          (saved-colors (append (#:display:colors display) ()))
          (saved-fonts (mapcar 'car (#:display:font-names display)))
          (saved-patterns (append (#:display:pattern-bitmaps display) ()))
          (saved-cursors (append (#:display:cursor-bitmaps display) ()))
          (saved-current-window (#:display:window display))
          (saved-focus-window (#:display:keyboard-focus-window display))
          (saved-event-mode (#:display:eventmode display))
          (saved-predefined (list 'saved-display
                                  (#:display:root-window display)
                                  (#:display:foreground display)
                                  (#:display:background display))))
      (setq saved-windows (delq (#:display:root-window display) saved-windows))
      (mapc (lambda (window)
              (unless (#:window:father window)
                      (check-window-position window)))
            saved-windows)
      (setq saved-colors (delq (#:display:foreground display) saved-colors))
      (setq saved-colors (delq (#:display:background display) saved-colors))
      (setq saved-fonts
            (delq (font-name (standard-roman-font display)) saved-fonts))
      (setq saved-fonts
            (delq (font-name (standard-bold-font display)) saved-fonts))
      (setq saved-fonts
            (delq (font-name (large-roman-font display)) saved-fonts))
      (setq saved-fonts
            (delq (font-name (small-roman-font display)) saved-fonts))
      
      (with ((current-display display))
            (flush-event))
      
      ; on envoie le message bitsave
      (when (and (#:display:check-display 'bitsave display)
                 (#:display:prologuep display))
            (send 'bitmap-save display)
            (:do-close display))
      
      (#:display:eventmode display saved-event-mode)
      (#:display:window display saved-current-window)
      (#:display:keyboard-focus-window display saved-focus-window)
      (#:display:windows display saved-windows)
      (#:display:menus display saved-menus)
      (#:display:bitmaps display saved-bitmaps)
      (#:display:menus display saved-menus)
      (#:display:colors display saved-colors)
      (#:display:font-names display saved-fonts)
      (#:display:pattern-bitmaps display saved-patterns)
      (#:display:cursor-bitmaps display saved-cursors)
      (#:display:extend display saved-predefined)
      display))

; bitmap-restore rouvre une liste de display sauvegardes par la precedente

(de bitmap-restore (displays)
    (mapc ':restore-a-display displays)
    displays)

(de :restore-a-display (display)
    (unless (and (consp (#:display:extend display))
                 (eq 'saved-display (car (#:display:extend display))))
            (error 'bitrestore errnotasaveddisplay display))
    (let ((saved-windows (#:display:windows display))
          (saved-bitmaps (#:display:bitmaps display))
          (saved-menus (#:display:menus display))
          (saved-colors (#:display:colors display))
          (saved-fonts (#:display:font-names display))
          (saved-patterns (#:display:pattern-bitmaps display))
          (saved-cursors (#:display:cursor-bitmaps display))
          (saved-root-window (#:display:root-window display))
          (saved-current-window (#:display:window display))
          (saved-focus-window (#:display:keyboard-focus-window display))
          (saved-event-mode (#:display:eventmode display display))
          (saved-predefined (#:display:extend display)))
      (#:display:windows display ())
      (#:display:bitmaps display ())
      (#:display:menus display ())
      (#:display:colors display ())
      (#:display:font-names display ())
      (#:display:pattern-bitmaps display ())
      (#:display:cursor-bitmaps display ())
      (#:display:extend display ())

      ; on simule un (bitprologue), sur un display deja alloue
      (send 'bitmap-restore display)
      (newl #:display:all-displays display)
      (#:display:prologuep display t)
      (unless (current-display) (current-display display))

      ; on reconstruit tous les objets
      (with ((current-display display))
            (nextl saved-predefined) ; saved-display
            (let ((newroot (root-window))
                  (oldroot (nextl saved-predefined)))
              (:exchange-and-subst newroot oldroot (#:display:windows display))
              (#:display:root-window display oldroot))
            (let ((newfore (standard-foreground))
                  (oldfore (nextl saved-predefined)))
              (:exchange-and-subst
               newfore oldfore (#:display:colors display))
              (#:display:foreground display oldfore)
              (#:graph-env:foreground (#:display:main-graph-env display)
                                      oldfore))
            (let ((newback (standard-background))
                  (oldback (nextl saved-predefined)))
              (:exchange-and-subst
               newback oldback (#:display:colors display))
              (#:display:background display oldback)
              (#:graph-env:background (#:display:main-graph-env display)
                                      oldback)))
            (mapc (lambda ((i w h bits))
                    (:exchange-and-subst
                     (create-bitmap w h bits) i
                     (#:display:bitmaps display)))
                  saved-bitmaps)
            (mapc (lambda (c)
                    (:exchange-and-subst
                     (if (#:color:name c)
                         (make-named-color (#:color:name c))
                       (if (#:color:mutable c)
                           (make-mutable-color (#:color:red c)
                                               (#:color:green c)
                                               (#:color:blue c))
                         (make-color (#:color:red c)
                                     (#:color:green c)
                                     (#:color:blue c))))
                     c
                     (#:display:colors display)))
                  saved-colors)
            (mapc 'load-font saved-fonts)
            (mapc 'make-pattern saved-patterns)
            (mapc (lambda ((b1 b2 x y))
                    (make-cursor b1 b2 x y))
                  saved-cursors)
            (:recreate-windows display saved-windows)
            (:recreate-menus display saved-menus)
            (current-window saved-current-window)
            (current-keyboard-focus-window saved-focus-window)
            (event-mode saved-event-mode)
            display
            )))

(de :recreate-windows (display windows)
    ; reconstruit les sous-fenetres de la liste windows
    ; si une fenetre a une pere qui n'a pas encore ete reconstruit
    ; on la colle en attente au bout de la liste
    ; ceci permet d'assurer que l'on reconstruit les peres avant les fils
    (when windows
          (if (and (#:window:father (car windows))
                   (not (windowp (#:window:father (car windows)))))
              (:recreate-windows display (append1 (cdr windows) (car windows)))
            (let* ((ge (#:window:graph-env (car windows)))
                   (bm (#:graph-env:bitmap ge))
                   (font (#:graph-env:font ge))
                   (line-style (#:graph-env:line-style ge))
                   (pattern (#:graph-env:pattern ge))
                   (mode (#:graph-env:mode ge))
                   (foreground (#:graph-env:foreground ge))
                   (background (#:graph-env:background ge))
                   (clip-x (#:graph-env:clip-x ge))
                   (clip-y (#:graph-env:clip-y ge))
                   (clip-w (#:graph-env:clip-w ge))
                   (clip-h (#:graph-env:clip-h ge))
                   (cursor (#:window:cursor (car windows))))
              (make-window (car windows))
              (with ((current-window (car windows)))
                    (current-font font)
                    (current-line-style line-style)
                    (current-pattern pattern)
                    (current-mode mode)
                    (current-foreground foreground)
                    (current-background background)
                    (current-clip clip-x clip-y clip-w clip-h)
                    (current-cursor cursor))
              (when bm
                    (let ((newbm (window-bitmap (car windows))))
                      (exchvector newbm bm)
                      (#:graph-env:bitmap (#:window:graph-env (car windows))
                                          bm))))
            (:recreate-windows display (cdr windows)))))

(de :recreate-menus (display menus)
    ; reconstruit les menus de la liste menus
    ; on insere les itemlists et les items a l'envers
    ; ce qui permet de toujours utiliser la position 0
    (mapc (lambda (menu)
            (let ((new-menu (create-menu (#:menu:name menu))))
              (mapc (lambda (il)
                      (menu-insert-item-list
                       new-menu
                       0
                       (#:menu:itemlist:name il)
                       (#:menu:itemlist:active il))
                      (mapc (lambda (i)
                              (menu-insert-item
                               new-menu
                               0
                               0
                               (#:menu:item:name i)
                               (#:menu:item:active i)
                               (#:menu:item:value i)))
                            (reverse (#:menu:itemlist:items il))))
                    (reverse (#:menu:itemlists menu)))
              (:exchange-and-subst new-menu menu (#:display:menus display))))
          menus))
                      

(de :exchange-and-subst (new old newlist)
    (exchvector new old)
    (rplaca (memq new newlist) old))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de bitepilogue displays
    (cond ((eq displays  ()) (setq displays (list (current-display))))
          ((eq (car displays) t) (setq displays #:display:all-displays)))
    (mapc
     (lambda (d)
       (when (and (#:display:check-display 'bitepilogue d)
                  (#:display:prologuep d))
             (send 'bitepilogue d)
             (:do-close d)))
     displays))

(de :do-close (d)
    (#:display:device d ())
    (#:display:prologuep d ())
    (#:display:eventmode d ())
    (#:display:xmax d ())
    (#:display:ymax d ())
    (#:display:keyboard-focus-window d ())
    (#:display:window d ())
    (#:display:graph-env d ())
    (#:display:root-window d ())
    (#:display:main-graph-env d ())
    (#:display:windows d ())
    (#:display:bitmaps d ())
    (#:display:menus d ())
    (#:display:colors d ())
    (#:display:font-names d ())
    (#:display:pattern-bitmaps d ())
    (#:display:cursor-bitmaps d ())
    (#:display:extend d ())
    (setq #:display:all-displays (delq d #:display:all-displays))
    (when (eq d (current-display))
          (if #:display:all-displays
              (current-display (car #:display:all-displays))
            (setq #:display:current-display ()))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de current-display &nobind
    (if (or (eq 0 (arg)) (eq #:display:current-display (arg 0)))
        #:display:current-display
      (when (#:display:check-display 'current-display (arg 0))
            (setq #:display:current-display (arg 0))
            (send 'current-display #:display:current-display)
            #:display:current-display)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de bitxmax &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if  (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'bitxmax display) 
            (#:display:xmax display))))

(de bitymax &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if  (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'bitymax display) 
            (#:display:ymax display))))

(de root-window &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'root-window display)
            (#:display:root-window display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de bitmap-refresh &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if  (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'bitmap-refresh display)
            (send 'bitmap-refresh display))))

(de bitmap-flush &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if  (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'bitmap-flush display)
            (send 'bitmap-flush display))))

(de bitmap-sync &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if  (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'bitmap-sync display)
            (send 'bitmap-sync display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de standard-roman-font &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'standard-roman-font display)
            (send 'standard-roman-font display))))

(de standard-bold-font &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'standard-bold-font display)
            (send 'standard-bold-font display))))

(de large-roman-font &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'large-roman-font display)
            (send 'large-roman-font display))))

(de small-roman-font &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'small-roman-font display)
            (send 'small-roman-font display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de standard-foreground-pattern &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'standard-foreground-pattern display)
            (send 'standard-foreground-pattern display))))

(de standard-background-pattern &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'standard-background-pattern display)
            (send 'standard-background-pattern display))))

(de standard-medium-gray-pattern &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'standard-medium-pattern display)
            (send 'standard-medium-gray-pattern display))))

(de standard-light-gray-pattern &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'standard-light-gray-pattern display)
            (send 'standard-light-gray-pattern display))))

(de standard-dark-gray-pattern &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'standard-dark-gray-pattern display) 
            (send 'standard-dark-gray-pattern display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de standard-lelisp-cursor &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'standard-lelisp-cursor display)
            (send 'standard-lelisp-cursor display))))

(de standard-gc-cursor &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'standard-gc-cursor display)
            (send 'standard-gc-cursor display))))

(de standard-busy-cursor &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'standard-busy-cursor display)
            (send 'standard-busy-cursor display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                    WINDOW                                   ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct #:image:rectangle x y w h)

(defstruct #:image:rectangle:window
  title
  hilited
  visible
  graph-env
  extend
  father
  properties
  (cursor 0)
  display
  subwindows)

(setq #:sys-package:colon 'window)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de create-window (type le to wi he ti hi vi)
    (setq type (compat-type type))
    (let ((create (getfn1 type 'create)))
      (unless create
              (error 'create-window errnotawindowtype type))
      (funcall create le to wi he ti hi vi)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de create-subwindow (type le to wi he ti hi vi fa)
    (when (or (null fa)
              (#:window:check-window 'create-subwindow
                                     (if fa 
                                         (#:window:display fa)
                                       (current-display))
                                     fa))
          (setq type (compat-type type))
          (let ((create (getfn1 type 'create)))
            (unless create
                    (error 'create-window errnotawindowtype type))
            (funcall create le to wi he ti hi vi fa))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de make-window (window)
    (unless (current-display) (bitprologue))    
    (let ((father (#:window:father window)))
      (when father
            (#:window:cursor window (#:window:cursor father))
            (#:window:display window (#:window:display father))
            (#:window:subwindows father
                                 (cons window (#:window:subwindows father)))))
    (unless (#:window:display window)
            (#:window:display window (current-display)))
    (unless (#:window:cursor window)
            (#:window:cursor window 0))
    (#:window:subwindows window ())
    (with ((current-display (#:window:display window)))
          (setq #:window:all-windows
                (#:display:windows (#:window:display window)
                                   (nconc1 (#:display:windows
                                            (#:window:display window))
                                           window)))
          (send 'make-window window)
          (when (#:window:graph-env window)
                (unless (#:graph-env:display (#:window:graph-env window))
                        (#:graph-env:display (#:window:graph-env window)
                                             (#:window:display window))))
          window))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de current-window &nobind
    (if (eq 0 (arg))
        (#:display:window (current-display))
      (let* ((window (arg 0))
             (display (if window (#:window:display window) (current-display))))
        (when (and display
                   (or (null window)
                       (#:window:check-window 'current-window display window)))
              (with ((current-display display))
                    (when (#:display:window display)
                          (send 'uncurrent-window (#:display:window display)))
                    (setq #:window:current-window
                          (#:display:window display window))
                    (setq #:graph-env:current-graph-env
                          (#:display:graph-env display
                                               (if window
                                                   (#:window:graph-env window)
                                                 (#:display:main-graph-env
                                                  display))))
                    (when (#:display:window display)
                          (send 'current-window (#:display:window display)))
                    window)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de modify-window (window le to wi he ti hi vi)
    (when (and
           (#:window:check-window 'modify-window (#:window:display window) window)
           (neq (root-window) window)
           (or le to wi he ti hi vi))
          (when (or wi he)
                (let* ((ge (#:window:graph-env window))
                       (b (#:graph-env:bitmap ge)))
                  (#:graph-env:clip-x ge 0)
                  (#:graph-env:clip-y ge 0)
                  (#:graph-env:clip-w ge (or wi (#:window:width window)))
                  (#:graph-env:clip-h ge (or he (#:window:height window)))
                  (when b
                        (#:bitmap:w b (#:graph-env:clip-w ge))
                        (#:bitmap:h b (#:graph-env:clip-h ge)))))
          (with ((current-display (#:window:display window)))
                (send 'modify-window window le to wi he ti hi vi))
          window))

(de update-window (window le to wi he)
    (when (and
           (#:window:check-window 'update-window  (#:window:display window) window)
           (neq (root-window) window)
           (or le to wi he))
          (when (or wi he)
                (let* ((ge (#:window:graph-env window))
                       (b (#:graph-env:bitmap ge)))
                  (#:graph-env:clip-x ge 0)
                  (#:graph-env:clip-y ge 0)
                  (#:graph-env:clip-w ge (or wi (#:window:width window)))
                  (#:graph-env:clip-h ge (or he (#:window:height window)))
                  (when b
                        (#:bitmap:w b (#:graph-env:clip-w ge))
                        (#:bitmap:h b (#:graph-env:clip-h ge)))))
          (with ((current-display (#:window:display window)))
                (send 'update-window window le to wi he))
          window))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de kill-window (window)
    (when (and
           (#:window:check-window 'kill-window (#:window:display window) window)
           (neq (root-window) window))
          (mapc 'kill-window (#:window:subwindows window))
          (when (#:window:father window)
                (#:window:subwindows (#:window:father window)
                                     (delq window (#:window:subwindows
                                                (#:window:father window)))))
          (with ((current-display (#:window:display window)))
                (when (eq window (#:display:window (#:window:display window)))
                      (current-window ()))
                (when (eq window (#:display:keyboard-focus-window
                               (#:window:display window)))
                      (current-keyboard-focus-window ()))
                (setq #:window:all-windows
                      (#:display:windows (#:window:display window)
                                         (delq window (#:display:windows
                                                    (#:window:display window)))))
                (send 'kill-window window)
                (#:window:display window ())
                (#:window:extend window ())
                (when (#:window:graph-env window)
                      (#:graph-env:display (#:window:graph-env window) ())
                      (#:graph-env:extend  (#:window:graph-env window) ())
                      (#:graph-env:bitmap (#:window:graph-env window) ())))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de pop-window (window)
    (when (and
           (#:window:check-window 'pop-window (#:window:display window) window)
           (neq (root-window) window))
          (with ((current-display (#:window:display window)))
                (setq #:window:all-windows
                      (#:display:windows (#:window:display window)
                                         (nconc1
                                          (delq window
                                                (#:display:windows
                                                 (#:window:display window)))
                                          window)))
                (send 'pop-window window))))

(de move-behind-window (window1 window2)
    (when (and (neq window1 window2)
               (#:window:check-windows 'move-behind-window window1 window2)
               (#:window:check-window 'move-behind-window
                                      (#:window:display window1) window1)
               (#:window:check-window 'move-behind-window
                                      (#:window:display window2) window2)
               (neq window1 (root-window))
               (neq window2 (root-window)))
          (with ((current-display (#:window:display window1)))
                (#:display:windows (#:window:display window1)
                                   (delq window1
                                         (nreverse
                                          (#:display:windows
                                           (#:window:display window1)))))
                (let ((all2 (memq window2 (#:display:windows
                                        (#:window:display window2)))))
                  (rplacd all2 (cons window1 (cdr all2))))
                (setq #:window:all-windows
                      (#:display:windows (#:window:display window2)
                                         (nreverse (#:display:windows
                                                    (#:window:display
                                                     window2)))))
                (send 'move-behind-window window1 window2))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de current-keyboard-focus-window &nobind
    (if (eq 0 (arg))
        (#:display:keyboard-focus-window (current-display))
      (let* ((window (arg 0))
             (display (if window (#:window:display window) (current-display))))
        (when (and display
                   (or (null window)
                       (#:window:check-window 'current-keyboard-focus-window
                                              display window)))
              (with ((current-display display))
                    (when (#:display:keyboard-focus-window display)
                          (send 'uncurrent-keyboard-focus-window
                                (#:display:keyboard-focus-window display)))
                    (setq #:window:current-keyboard-focus-window
                          (#:display:keyboard-focus-window display window))
                    (when window                 
                          (send 'current-keyboard-focus-window window))
                    window)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de find-window (x y)
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'find-window (current-display) x y)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de map-window (window :x :y :lx :ly)
    (when (and
           (#:window:check-window 'map-window (#:window:display window) window)
           (neq (root-window) window))
          (send 'map-window window :x :y :lx :ly))
    ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                            UTILITAIRES                                      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de windowp (window)
    (and (typep window '#:image:rectangle:window)
         (#:window:extend window)
         (#:window:display window)
         window))

(de subwindowp (window1 window2)
    (and (windowp window1)
         (windowp window2)
         (#:window:check-windows 'subwindowp window1 window2)
         (subwindowp1 window1 window2)))

(de subwindowp1 (window1 window2)
    (ifn window1 ()
	 (if (eq window1 window2)
	     window1
	   (subwindowp1 (#:window:father window1) window2))))

(de which-window ()
    (unless (current-display) (bitprologue))
    (read-mouse)
    (find-window #:mouse:x #:mouse:y))

(de check-window-position (window)
    (map-window window 0 0 '#:check-window:x '#:check-window:y)
    (setq #:check-window:x (sub 0 #:check-window:x))
    (setq #:check-window:y (sub 0 #:check-window:y))
    (unless (and (eq (#:window:left window) #:check-window:x)
                 (eq (#:window:top  window) #:check-window:y))
            (update-window window 
                           #:check-window:x #:check-window:y
                           () ())))

(dmd define-window-property-accessor (propertyname)
     `(de ,(symbol '#:image:rectangle:window propertyname) &nobind
          (if (eq (arg) 1)
              (cassq ',propertyname
                     (#:image:rectangle:window:properties (arg 0)))
            (#:image:rectangle:window:set-property
             (arg 0)
             ',propertyname (arg 1)))))

(de #:image:rectangle:window:set-property (window name val)
    (let ((pair (assq name (#:image:rectangle:window:properties window))))
      (if pair
          (rplacd pair val)
        (#:image:rectangle:window:properties
         window
         (acons name val (#:image:rectangle:window:properties window))))))

(de compat-type (type)
    (selectq type 
             (window '#:image:rectangle:window)
             (#:window:tty '#:image:rectangle:window:tty)
             (t type)))

(de #:image:rectangle:window:create (le to wi he ti hi vi . fa)
    (let ((window (#:window:make)))
      (#:window:left window le)
      (#:window:top window to)
      (#:window:width window wi)
      (#:window:height window he)
      (#:window:title window ti)
      (#:window:hilited window hi)
      (#:window:visible window vi)
      (#:window:father window (when fa (car fa)))
      (make-window window)))

(de #:image:rectangle:window:prin (window)
    (princn #/#)
    (princn #/<)
    (prin (type-of window))
    (princn #\sp)
    (prin (#:window:title window))
    (princn #/>))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                           COMPATIBILITE                                     ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(dmd #:window:make ()
     '(#:image:rectangle:window:make))

(dmd #:window:left (w . r)
     (if r `(vset ,w 0 ,(car r)) `(vref ,w 0)))

(dmd #:window:top (w . r)
     (if r `(vset ,w 1 ,(car r)) `(vref ,w 1)))

(dmd #:window:width (w . r)
     (if r `(vset ,w 2 ,(car r)) `(vref ,w 2)))

(dmd #:window:height (w . r)
     (if r `(vset ,w 3 ,(car r)) `(vref ,w 3)))

(dmd #:window:title (w . r)
     (if r `(vset ,w 4 ,(car r)) `(vref ,w 4)))

(dmd #:window:hilited (w . r)
     (if r `(vset ,w 5 ,(car r)) `(vref ,w 5)))

(dmd #:window:visible (w . r)
     (if r `(vset ,w 6 ,(car r)) `(vref ,w 6)))

(dmd #:window:graph-env (w . r)
     (if r `(vset ,w 7 ,(car r)) `(vref ,w 7)))

(dmd #:window:extend (w . r)
     (if r `(vset ,w 8 ,(car r)) `(vref ,w 8)))

(dmd #:window:father (w . r)
     (if r `(vset ,w 9 ,(car r)) `(vref ,w 9)))

(dmd #:window:properties (w . r)
     (if r `(vset ,w 10 ,(car r)) `(vref ,w 10)))

(dmd #:window:cursor (w . r)
     (if r `(vset ,w 11 ,(car r)) `(vref ,w 11)))

(dmd #:window:display (w . r)
     (if r `(vset ,w 12 ,(car r)) `(vref ,w 12)))

(dmd #:window:subwindows (w . r)
     (if r `(vset ,w 13 ,(car r)) `(vref ,w 13)))

(de  #:window:create l
     (apply '#:image:rectangle:window:create l))

(de  #:window:prin (window)
     (#:image:rectangle:window:prin window))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                            INDIRECTIONS                                     ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de #:image:rectangle:window:make-window (window)
    (if (#:window:father window)
        (send 'create-subwindow (#:window:display window) window)
      (send 'create-window (#:window:display window) window))
    window)

(de #:image:rectangle:window:current-window (window)
    (send 'current-window (#:window:display window) window))

(de #:image:rectangle:window:uncurrent-window (window)
    (send 'uncurrent-window (#:window:display window) window))

(de #:image:rectangle:window:modify-window (window le to wi he ti hi vi)
    (send 'modify-window (#:window:display window) window le to wi he ti hi vi))

(de #:image:rectangle:window:update-window (window le to wi he)
    (send 'update-window (#:window:display window) window le to wi he))

(de #:image:rectangle:window:kill-window (window)
    (send 'kill-window (#:window:display window) window))

(de #:image:rectangle:window:pop-window (window)
    (send 'pop-window (#:window:display window) window)) 

(de #:image:rectangle:window:move-behind-window (window1 window2)
    (send 'move-behind-window (#:window:display window1) window1 window2))

(de #:image:rectangle:window:current-keyboard-focus-window (window)
    (send 'current-keyboard-focus-window (#:window:display window) window))

(de #:image:rectangle:window:uncurrent-keyboard-focus-window (window)
    (send 'uncurrent-keyboard-focus-window (#:window:display window) window))

(de #:image:rectangle:window:map-window (window :x :y :lx :ly)
    (send 'map-window (#:window:display window) window :x :y :lx :ly))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                COLOR                                        ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setq #:sys-package:colon 'color)

(defstruct color 
  name
  red
  green 
  blue
  mutable
  display
  extend)

(de #:color:prin (c)
    (princn #/#)
    (princn #/<)
    (prin (type-of c))
    (princn #\sp)
    (prin (#:color:name c))
    (princn #\sp)
    (prin (#:color:red c))
    (princn #\sp)
    (prin (#:color:green c))
    (princn #\sp)
    (prin (#:color:blue c))
    (princn #\sp)
    (prin (#:color:extend c))
    (princn #/>))

(de standard-foreground ()
    (unless (current-display) (bitprologue))
    (#:display:foreground (current-display)))

(de standard-background ()
    (unless (current-display) (bitprologue))
    (#:display:background (current-display)))

(de make-color (red green blue)
    (unless (current-display) (bitprologue))
    (let ((color (#:color:make)))
      (#:color:display color (current-display))
      (#:color:red color red)
      (#:color:green color green)
      (#:color:blue color blue)
      (setq color (send 'make-color (current-display) color red green blue))
      (unless (memq color (#:display:colors (current-display)))
              (#:display:colors
               (current-display)
               (nconc1 (#:display:colors (current-display)) color)))
      color))

(de make-mutable-color (red green blue)
    (unless (current-display) (bitprologue))
    (let ((color (#:color:make)))
      (#:color:display color (current-display))
      (#:color:red color red)
      (#:color:green color green)
      (#:color:blue color blue)
      (#:color:mutable color t)
      (setq color
            (send 'make-mutable-color (current-display) color red green blue))
      (unless (memq color (#:display:colors (current-display)))
              (#:display:colors
               (current-display)
               (nconc1 (#:display:colors (current-display)) color)))
      color))

(de make-named-color (name)
    (unless (current-display) (bitprologue))
    (let ((color (#:color:make)))
      (#:color:display color (current-display))
      (#:color:name color name)
      (setq color (send 'make-named-color (current-display) color name))
      (unless (memq color (#:display:colors (current-display)))
              (#:display:colors
               (current-display)
               (nconc1 (#:display:colors (current-display)) color)))
      color))

(de kill-color (color)
    (when (#:color:check-color 'kill-color (#:color:display color) color)
          (send 'kill-color (#:color:display color) color)
          (#:display:colors (#:color:display color)
                            (delq color 
                                  (#:display:colors (#:color:display color))))
          (#:color:extend color ())
          (#:color:display color ())))

(de red-component &nobind
    (let ((arg (arg)) (color (arg 0)) (red (arg 1)))
      (when (#:color:check-color 'red-component (#:color:display color) color)
            (if (eq 1 arg)
                (#:color:red color)
              (unless (#:color:mutable color)
                      (error 'red-component errnotamutable color))
              (send 'red-component (#:color:display color) color red)
              (#:color:red color red)))))

(de blue-component &nobind
    (let ((arg (arg)) (color (arg 0)) (blue (arg 1)))
      (when (#:color:check-color 'blue-component (#:color:display color) color)
            (if (eq 1 arg)
                (#:color:blue color)
              (unless (#:color:mutable color)
                      (error 'blue-component errnotamutable color))
              (send 'blue-component (#:color:display color) color blue)
              (#:color:blue color blue)))))

(de green-component &nobind
    (let ((arg (arg)) (color (arg 0)) (green (arg 1)))
      (when (#:color:check-color 'green-component (#:color:display color)
                                 color)
            (if (eq 1 arg)
                (#:color:green color)
              (unless (#:color:mutable color)
                      (error 'green-component errnotamutable color))
              (send 'green-component (#:color:display color) color green)
              (#:color:green color green)))))

(de all-colors &nobind
    (unless (current-display) (bitprologue))
    (let ((display (if  (eq (arg) 0) (current-display) (arg 0))))
      (when (#:display:check-display 'all-colors display) 
            (#:display:colors display))))

(de current-foreground &nobind
    (let ((arg (arg)) (color (arg 0)))
      (if (eq 0 arg)
          (#:graph-env:foreground (#:display:graph-env (current-display)))
        (when (#:color:check-color 'current-foreground 
                                   (#:color:display color) color)
              (send 'current-foreground 
                    (#:display:graph-env (#:color:display color)) color)
              (#:graph-env:foreground 
               (#:display:graph-env (#:color:display color)) color)))))

(de current-background &nobind
    (let ((arg (arg)) (color (arg 0)))
      (if (eq 0 arg)
          (#:graph-env:background (#:display:graph-env (current-display)))
        (when (#:color:check-color 'current-background 
                                   (#:color:display color) color)
              (send 'current-background 
                    (#:display:graph-env (#:color:display color)) color)
              (#:graph-env:background 
                    (#:display:graph-env (#:color:display color)) color)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de #:graph-env:current-foreground (ge fore)
    (send 'current-foreground (#:graph-env:display ge) ge fore))

(de #:graph-env:current-background (ge back)
    (send 'current-background (#:graph-env:display ge) ge back))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                   GRAPH-ENV                                 ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct graph-env 
  (font 0)
  (line-style 0)
  (pattern 1)
  (mode 3)
  foreground 
  background
  (clip-x 0)
  (clip-y 0)
  (clip-w 0)
  (clip-h 0)
  bitmap
  display
  extend)

(setq #:sys-package:colon 'graph-env)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de clear-graph-env ()
    (when (current-display)
          (send 'clear-graph-env (#:display:graph-env (current-display)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de current-clip &nobind
    (when (current-display)
          (let ((ge (#:display:graph-env (current-display)))
                (arg (arg))
                (x (arg 0))
                (y (arg 1))
                (w (arg 2))
                (h (arg 3)))
            (if (eq arg 0)
                (progn (setq #:clip:x (#:graph-env:clip-x ge))
                       (setq #:clip:y (#:graph-env:clip-y ge))
                       (setq #:clip:w (#:graph-env:clip-w ge))
                       (setq #:clip:h (#:graph-env:clip-h ge)))
              (#:graph-env:clip-x ge x)
              (#:graph-env:clip-y ge y)
              (#:graph-env:clip-w ge w)
              (#:graph-env:clip-h ge h)
              (send 'current-clip ge x y w h)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de draw-cursor (x y state)
    (when (current-display)
          (send 'draw-cursor (#:display:graph-env (current-display))
                x y state)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de current-font &nobind
    (when (current-display)
          (let ((ge (#:display:graph-env (current-display)))
                (arg (arg))
                (font (arg 0)))
            (if (eq arg 0)
                (#:graph-env:font ge)
              (ifn (and (fixp font) (ge font 0) (le font (font-max)))
                   (error 'current-font 'erroob font)
                   (send 'current-font ge font)
                   (#:graph-env:font ge font))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de font-max ()
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'font-max (#:display:graph-env (current-display)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de load-font (font)
    (unless (current-display) (bitprologue))
    (or (cassoc font (#:display:font-names (current-display)))
        (let ((f (send 'load-font (#:display:graph-env (current-display))
                       font)))
          (#:display:font-names 
           (current-display)
           (nconc1 (#:display:font-names (current-display)) (cons font f)))
          f)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de font-name (font)
    (unless (current-display) (bitprologue))    
    (let ((pair (rassoc font (#:display:font-names (current-display)))))
      (ifn pair
           (error 'font-name 'erroob font)
           (car pair))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de draw-substring (x y s start length)
    (when (current-display)
          (send 'draw-substring (#:display:graph-env (current-display))
                x y s start length)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de draw-cn (x y cn)
    (when (current-display)
          (send 'draw-cn (#:display:graph-env (current-display)) x y cn)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de width-substring (s start length)
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'width-substring (#:display:graph-env (current-display))
                s start length)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de height-substring (s start length)
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'height-substring (#:display:graph-env (current-display))
                s start length)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de x-base-substring (s start length)
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'x-base-substring (#:display:graph-env (current-display))
                s start length)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de y-base-substring (s start length)
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'y-base-substring (#:display:graph-env (current-display))
                s start length)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de x-inc-substring (s start length)
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'x-inc-substring (#:display:graph-env (current-display))
                s start length)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de y-inc-substring (s start length)
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'y-inc-substring (#:display:graph-env (current-display))
                s start length)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de current-line-style &nobind
    (when (current-display)
          (let ((ge (#:display:graph-env (current-display)))
                (arg (arg))
                (line-style (arg 0)))
            (if (eq 0 arg)
                (#:graph-env:line-style ge)
              (ifn (and (fixp line-style) (ge line-style 0)
                        (le line-style (line-style-max)))
                   (error 'current-line-style 'erroob line-style)
                   (send 'current-line-style ge line-style)
                   (#:graph-env:line-style ge line-style))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de line-style-max ()
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'line-style-max (#:display:graph-env (current-display)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de current-pattern &nobind
    (when (current-display)
          (let ((ge (#:display:graph-env (current-display)))
                (arg (arg))
                (pattern (arg 0)))
            (if (eq 0 arg)
                (#:graph-env:pattern ge)
              (ifn (and (fixp pattern) (ge pattern 0)
                        (le pattern (pattern-max)))
                   (error 'current-pattern 'erroob pattern)
                   (send 'current-pattern ge pattern)
                   (#:graph-env:pattern ge pattern))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de pattern-max ()
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'pattern-max (#:display:graph-env (current-display)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de make-pattern (bitmap)
    (when (#:bitmap:check-bitmap 'make-pattern
                                 (#:bitmap:display bitmap) bitmap)
          (let ((display (#:bitmap:display bitmap)))
            (with ((current-display display))
                  (let ((b (send 'make-pattern 
                                 (#:display:graph-env display)
                                 bitmap)))
                    (#:display:pattern-bitmaps 
                     display
                     (nconc1 (#:display:pattern-bitmaps display) bitmap))
                    b)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de current-mode &nobind
    (when (current-display)
          (let ((ge (#:display:graph-env (current-display)))
                (arg (arg))
                (mode (arg 0)))
            (if (eq 0 arg)
                (#:graph-env:mode ge)
              (ifn (and (fixp mode) (ge mode 0) (le mode 16))
                   (error 'current-mode 'erroob mode)
                   (send 'current-mode ge mode)
                   (#:graph-env:mode ge mode))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de draw-point (x y)
    (when (current-display)
          (send 'draw-point (#:display:graph-env (current-display)) x y)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de draw-polymarker (n vx vy)
    (when (current-display)
          (send 'draw-polymarker (#:display:graph-env (current-display))
                n vx vy)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de draw-line (x0 y0 x1 y1)
    (when (current-display)
          (send 'draw-line (#:display:graph-env (current-display)) 
                x0 y0 x1 y1)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de draw-polyline (n vx vy)
    (when (current-display)
          (send 'draw-polyline (#:display:graph-env (current-display))
                n vx vy)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de draw-rectangle (x y w h)
    (when (current-display)
          (send 'draw-rectangle (#:display:graph-env (current-display))
                x y w h)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de fill-rectangle (x y w h)
    (when (current-display)
          (send 'fill-rectangle (#:display:graph-env (current-display))
                x y w h)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de fill-area (n vx vy)
    (when (current-display)
          (send 'fill-area (#:display:graph-env (current-display)) n vx vy)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de draw-ellipse (x y rx ry)
    (when (current-display)
          (send 'draw-ellipse (#:display:graph-env (current-display))
                x y rx ry)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de fill-ellipse (x y rx ry)
    (when (current-display)
          (send 'fill-ellipse (#:display:graph-env (current-display))
                x y rx ry)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de draw-circle (x y r)
    (when (current-display)
          (send 'draw-circle (#:display:graph-env (current-display)) x y r)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de fill-circle (x y r)
    (when (current-display)
          (send 'fill-circle (#:display:graph-env (current-display)) x y r)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;                           INDIRECTIONS                                      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de #:graph-env:clear-graph-env (ge)
    (send 'clear-graph-env (#:graph-env:display ge) ge))

(de #:graph-env:current-clip (ge x y w h)
    (send 'current-clip (#:graph-env:display ge) ge x y w h))

(de #:graph-env:draw-cursor (ge x y st)
    (send 'draw-cursor (#:graph-env:display ge) ge x y st))

(de #:graph-env:current-font (ge font)
    (send 'current-font (#:graph-env:display ge) ge font))

(de #:graph-env:font-max (ge) 
    (send 'font-max (#:graph-env:display ge) ge))

(de #:graph-env:load-font (ge font)
    (send 'load-font (#:graph-env:display ge) ge font))

(de #:graph-env:font-name (ge font)
    (send 'font-name (#:graph-env:display ge) ge font))

(de #:graph-env:draw-cn (ge x y cn)
    (send 'draw-cn (#:graph-env:display ge) ge x y cn))

(de #:graph-env:draw-substring (ge x y s st le)
    (send 'draw-substring (#:graph-env:display ge) ge x y s st le))

(de #:graph-env:width-substring (ge s st le)
    (send 'width-substring (#:graph-env:display ge) ge s st le))

(de #:graph-env:height-substring (ge s st le)
    (send 'height-substring (#:graph-env:display ge) ge s st le))

(de #:graph-env:x-base-substring (ge s st le)
    (send 'x-base-substring (#:graph-env:display ge) ge s st le))

(de #:graph-env:y-base-substring (ge s st le)
    (send 'y-base-substring (#:graph-env:display ge) ge s st le))

(de #:graph-env:x-inc-substring (ge s st le)
    (send 'x-inc-substring (#:graph-env:display ge) ge s st le))

(de #:graph-env:y-inc-substring (ge s st le) 
    (send 'y-inc-substring (#:graph-env:display ge) ge s st le))

(de #:graph-env:line-style-max (ge) 
    (send 'line-style-max (#:graph-env:display ge) ge))

(de #:graph-env:current-line-style (ge line-style)
    (send 'current-line-style (#:graph-env:display ge) ge line-style))

(de #:graph-env:pattern-max (ge)
    (send 'pattern-max (#:graph-env:display ge) ge))

(de #:graph-env:current-pattern (ge pattern)
    (send 'current-pattern (#:graph-env:display ge) ge pattern))

(de #:graph-env:make-pattern (ge bitmap)
    (send 'make-pattern (#:graph-env:display ge) ge bitmap))

(de #:graph-env:current-mode (ge mode)
    (send 'current-mode (#:graph-env:display ge) ge mode))

(de #:graph-env:draw-point (ge x0 y0)
    (send 'draw-point (#:graph-env:display ge) ge x0 y0))

(de #:graph-env:draw-polymarker (ge n vx vy)
    (send 'draw-polymarker (#:graph-env:display ge) ge n vx vy))

(de #:graph-env:draw-line (ge x0 y0 x1 y1)
    (send 'draw-line (#:graph-env:display ge) ge x0 y0 x1 y1))

(de #:graph-env:draw-polyline (ge n vx vy)
    (send 'draw-polyline (#:graph-env:display ge) ge n vx vy))

(de #:graph-env:draw-rectangle (ge x y w h)
    (send 'draw-rectangle (#:graph-env:display ge) ge x y w h))

(de #:graph-env:fill-area (ge n vx vy)
    (send 'fill-area (#:graph-env:display ge) ge n vx vy))

(de #:graph-env:fill-rectangle (ge x y w h)
    (send 'fill-rectangle (#:graph-env:display ge) ge x y w h))

(de #:graph-env:draw-ellipse (ge x y rx ry) 
    (send 'draw-ellipse (#:graph-env:display ge) ge x y rx ry))

(de #:graph-env:fill-ellipse (ge x y rx ry) 
    (send 'fill-ellipse (#:graph-env:display ge) ge x y rx ry))

(de #:graph-env:fill-circle (ge x y r) 
    (send 'fill-circle (#:graph-env:display ge) ge x y r))

(de #:graph-env:draw-circle (ge x y r)
    (send 'draw-circle (#:graph-env:display ge) ge x y r))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                  UTILITAIRES                                ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(dmd draw-string (x y s)
     `(let ((#:graph-env:arg0 ,s))
        (draw-substring ,x ,y #:graph-env:arg0 0 (slen #:graph-env:arg0))))

(de width-space ()
    (width-substring  " " 0 1))

(de height-space ()
    (height-substring " " 0 1))

(de x-base-space ()
    (x-base-substring " " 0 1))

(de y-base-space ()
    (y-base-substring " " 0 1))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                               CURSOR                                        ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de cursor-max ()
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'cursor-max (current-display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de make-cursor (b1 b2 x y)
    (when (and (#:bitmap:check-bitmaps 'make-cursor b1 b2)
               (#:bitmap:check-bitmap 'make-cursor (#:bitmap:display b1) b1)
               (#:bitmap:check-bitmap 'make-cursor (#:bitmap:display b2) b2))
          (with ((current-display (#:bitmap:display b1)))
                (let ((c (send 'make-cursor (#:bitmap:display b1) b1 b2 x y)))
                  (#:display:cursor-bitmaps 
                   (current-display) 
                   (nconc1 (#:display:cursor-bitmaps (current-display))
                           (list b1 b2 x y)))
                  c))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de current-cursor &nobind
    (when (current-display)
          (let ((window (#:display:window (current-display)))
                (arg (arg))
                (cursor (arg 0)))
            (if (eq 0 arg)
                (#:window:cursor window)
              (ifn (and (fixp cursor) (ge cursor 0) (le cursor (cursor-max)))
                   (error 'current-cursor 'erroob cursor)
                   (send 'current-cursor (current-display) cursor)
                   (#:window:cursor window cursor))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de move-cursor (x y)
    (unless (current-display) (bitprologue))
    (when (current-display)
          (send 'move-cursor (current-display) x y)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                     EVENT                                   ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setq #:sys-package:colon 'mouse)

(defstruct event 
  code
  window
  detail
  gx
  gy
  x
  y
  w
  h)

(unless (boundp '#:mouse:event) (defvar #:mouse:event (#:event:make)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de event-mode &nobind
    (when (current-display)
          (if (eq (arg) 0) 
              (#:display:eventmode (current-display))
            (send 'event-mode (current-display) (arg 0))
            (setq #:mouse:event-mode 
                  (#:display:eventmode (current-display) (arg 0))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de eventp ()
    (when (current-display)
          (send 'eventp (current-display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de read-event &nobind
    (when (current-display)
          (let ((event (if (eq (arg) 1) (arg 0) #:mouse:event)))
            (send 'read-event (current-display) event)
            (parse-event event)
            event)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de peek-event &nobind
    (when (current-display)
          (let ((event (if (eq (arg) 1) (arg 0) #:mouse:event)))
            (send 'peek-event (current-display) event)
            (parse-event event)
            event)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de local-read-event ()
    (when (current-display)
          (read-event #:mouse:event)
          (map-window (current-window) #:event:x #:event:y
                      '#:event:x '#:event:y)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de flush-event ()
    (when (current-display)
          (send 'flush-event (current-display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de add-event &nobind
    (when (current-display)
          (cond ((eq (arg) 1)
                 (let ((event (arg 0)))
                   (send 'add-event (current-display) event)))
                ((eq (arg) 3)
                 (#:event:gx #:mouse:event (arg 0))
                 (#:event:gy #:mouse:event (arg 1))
                 (#:event:code #:mouse:event (arg 2))
                 (send 'add-event (current-display) #:mouse:event)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(de grab-event (window)
    (if window
        (when (#:window:check-window 'grab-event (#:window:display window) window)
              (send 'grab-event (#:window:display window) window)
              window)
      (when (current-display)
            (send 'ungrab-event (current-display))
            ())))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de ungrab-event ()
    (when (current-display)
          (send 'ungrab-event (current-display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de itsoft-event ()
    (when (current-display)
          (send 'itsoft-event (current-display))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de read-mouse &nobind
    (when (current-display)
          (let ((event (if (eq (arg) 1) (arg 0) #:mouse:event)))
            (send 'read-mouse (current-display) event)
            (parse-mouse event)
            event)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                  UTILITAIRES                                ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de parse-event (event)
    (setq #:event:x (#:event:gx event))
    (setq #:event:y (#:event:gy event))
    (setq #:event:code 
          (selectq (#:event:code event)
                   (ascii-event (#:event:detail event))
                   ((move-event up-event) 257)
                   ((down-event drag-event) 258)
                   (t 256))))

(de parse-mouse (event)
    (setq #:mouse:x (#:event:gx event))
    (setq #:mouse:y (#:event:gy event))
    (setq #:mouse:state (#:event:detail event)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                  MENU                                       ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct menu
  name
  itemlists
  display
  extend)

(setq #:sys-package:colon 'menu)

(defstruct :itemlist
  name
  active
  items)

(de :itemlist (name active items)
    (let ((res (:itemlist:make)))
      (:itemlist:name res name)
      (:itemlist:active res active)
      (:itemlist:items res items)
      res))

(defstruct :item
  name
  active
  value)

(de :item (name active value)
    (let ((res (:item:make)))
      (:item:name res name)
      (:item:active res active)
      (:item:value res value)
      res))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de create-menu (title . values)
    (unless (current-display) (bitprologue))    
    (let ((menu (#:menu:make))
          (i -1))
      (#:menu:display menu (current-display))
      (#:menu:name menu title)
      (setq menu (send 'create-menu (#:menu:display menu) menu))
      (#:menu:display menu (current-display))
      (#:menu:name menu title)
      (#:display:menus (current-display) 
                       (nconc1 (#:display:menus (current-display)) menu))
      (menu-insert-item-list menu 0 title 1)
      (while values
        (menu-insert-item menu 0 (incr i)
                          (nextl values) 1 (nextl values)))
      menu))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de kill-menu (menu)
    (when (#:menu:check-menu 'kill-menu (#:menu:display menu) menu)
          (send 'kill-menu (#:menu:display menu) menu)
          (#:display:menus (#:menu:display menu) 
                           (delq menu (#:display:menus (#:menu:display menu))))
          (#:menu:extend menu ())
          (#:menu:display menu ())))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de activate-menu (menu x y)
    (when (#:menu:check-menu 'activate-menu (#:menu:display menu) menu)
          (with ((current-display (#:menu:display menu)))
                (send 'activate-menu (#:menu:display menu) menu x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de menu-insert-item-list (menu choix name active)
    (when (#:menu:check-menu 'menu-insert-item-list (#:menu:display menu) menu)
          (:itemlists menu
                      (insertnth choix (:itemlists menu)
                                 (:itemlist name active ())))
          (send 'menu-insert-item-list 
                (#:menu:display menu) menu choix name active)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de menu-insert-item (menu choix index name active value)
    (when (#:menu:check-menu 'menu-insert-item (#:menu:display menu) menu)
          (let ((il (nth choix (:itemlists menu))))
            (when il
                  (:itemlist:items il
                                   (insertnth index
                                              (:itemlist:items il)
                                              (:item name active value)))))
          (send 'menu-insert-item (#:menu:display menu)
                menu choix index name active value)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de menu-delete-item-list (menu choix)
    (when (#:menu:check-menu 'menu-delete-item-list (#:menu:display menu) menu)
          (:itemlists menu (deletenth choix (:itemlists menu))))
          (send 'menu-delete-item-list (#:menu:display menu) menu choix)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de menu-delete-item (menu choix index)
    (when (#:menu:check-menu 'menu-delete-item (#:menu:display menu) menu)
          (let ((il (nth choix (:itemlists menu))))
            (when il
                  (:itemlist:items il
                                   (deletenth index (:itemlist:items il)))))
          (send 'menu-delete-item (#:menu:display menu) menu choix index)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de menu-modify-item-list (menu choix name active)
    (when (#:menu:check-menu 'menu-modify-item-list (#:menu:display menu) menu)
          (let ((il (nth choix (:itemlists menu))))
            (when il
                  (when name (:itemlist:name il (string name)))
                  (when active (:itemlist:name il active))))
          (send 'menu-modify-item-list 
                (#:menu:display menu) menu choix name active)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de menu-modify-item (menu choix index name active value)
    (when (#:menu:check-menu 'menu-modify-item (#:menu:display menu) menu)
          (let ((il (nth choix (:itemlists menu))))
            (when il
                  (let ((item (nth index il)))
                    (when name (:item:name item (string name)))
                    (when active (:item:name item active))
                    (when value (:item:name item value)))))
          (send 'menu-modify-item
                (#:menu:display menu) menu choix index name active value)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de deletenth (n l)
    (cond ((atom l) l)
          ((eq n 0) (cdr l))
          (t
           (rplacd l (deletenth (sub1 n) (cdr l))))))

(de insertnth (n l i)
    (cond ((atom l) (cons i l))
          ((eq n 0) (cons i l))
          (t
           (rplacd l (insertnth (sub1 n) (cdr l) i)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                   BITMAP                                    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct bitmap
  w
  h
  extend
  display)

(setq #:sys-package:colon 'bitmap)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; CREATE-BITMAP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de create-bitmap (w h . bits)
    (unless (current-display) (bitprologue))    
    (let ((bitmap (#:bitmap:make)))
      (:w bitmap w)
      (:h bitmap h)
      (:display bitmap (current-display))
      (setq bitmap (send 'create-bitmap (:display bitmap) bitmap))
      (:w bitmap w)
      (:h bitmap h)
      (:display bitmap (current-display))
      (#:display:bitmaps (current-display)
                         (nconc1 (#:display:bitmaps (current-display))
                                 bitmap))
      (:bits bitmap
             (if bits
                 (car bits)
               (makevector h (makestring (:round-to-byte w) 0))))
      bitmap))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WINDOW-BITMAP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de window-bitmap (window)
    (when (#:window:check-window 'window-bitmap 
                                 (#:window:display window) window)
          (or (#:graph-env:bitmap (#:window:graph-env window))
              (let ((bitmap (#:bitmap:make)))
                (:display bitmap (#:window:display window))
                (:w bitmap (#:window:width window))
                (:h bitmap (#:window:height window))
		(setq bitmap (send 'create-window-bitmap
				   (#:window:display window)
				   window
				   bitmap))
                (:display bitmap (#:window:display window))
                (:w bitmap (#:window:width window))
                (:h bitmap (#:window:height window))
                (#:graph-env:bitmap (#:window:graph-env window) bitmap)
                bitmap))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; KILL-BITMAP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de kill-bitmap (bitmap)
    (when (#:bitmap:check-bitmap 'kill-bitmap (#:bitmap:display bitmap) bitmap)
          (send 'kill-bitmap (:display bitmap) bitmap)
          (#:display:bitmaps (#:bitmap:display bitmap)
                             (delq bitmap (#:display:bitmaps 
                                           (#:bitmap:display bitmap))))
          (#:bitmap:extend bitmap ())
          (#:bitmap:display bitmap ())))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; BMREF et BMSET ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de bmref (bitmap x y)
    (when (#:bitmap:check-bitmap 'bmref (#:bitmap:display bitmap) bitmap)
          (send 'bmref (:display bitmap) bitmap x y)))

(de bmset (bitmap x y bit)
    (when (#:bitmap:check-bitmap 'bmset (#:bitmap:display bitmap) bitmap)
          (send 'bmset (:display bitmap) bitmap x y bit)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; BITBLIT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de bitblit (b1 b2 x1 y1 x2 y2 w h)
    (when (and (#:bitmap:check-bitmaps 'bitblit b1 b2)
               (#:bitmap:check-bitmap 'bitblit (#:bitmap:display b1) b1)
               (#:bitmap:check-bitmap 'bitblit (#:bitmap:display b2) b2))
          (send 'bitblit (:display b1) b1 b2 x1 y1 x2 y2 w h)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                   UTILITAIRES                               ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de #:sharp:* arg
    (ncons (#:bitvector:read (car arg) ())))

(de #:sharp:|B| ()
    (ncons (apply 'create-bitmap (read))))

(de #:bitmap:bits (bitmap . bits)
    (if (null bits)
        (let* ((hbitmap     (#:bitmap:h bitmap))
	       (wbitmap     (#:bitmap:w bitmap))
	       (strg-size   (:round-to-byte wbitmap))
	       (strg-indmax (sub1 strg-size))
	       (last-bits   (logand wbitmap 7))
	       (vect        (makevector hbitmap ()))
	       (bitvector   ())
	       (i 0))
	  (repeat hbitmap
                  (setq bitvector (makestring strg-size 0))
                  (vset vect i bitvector)
                  (typestring bitvector 'bitvector)
                  (send 'get-bit-line (:display bitmap) bitmap i bitvector)
                  (when (neq last-bits 0)
                        (sset bitvector
                              strg-indmax
                              (mask-field (sref bitvector strg-indmax)
                                          (sub 8 last-bits)
                                          8)))
                  (setq i (add1 i)))
          vect)
      (let ((vect (car bits))
            (bitline)
            (olbitline)
            (n 0)
            (i 0))
        (repeat (vlength vect)
                (setq bitline (vref vect n))
                (setq n (add1 n))
                (if (fixp bitline)
                    (repeat bitline
                            (send 'set-bit-line (:display bitmap)
                                  bitmap i olbitline)
                            (setq i (add1 i)))
		  (send 'set-bit-line (:display bitmap) bitmap i bitline)
		  (setq i (add1 i))
		  (setq olbitline bitline))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; La variable #:SYSTEM:COMPRESSED-ICON permet d'imprimer les bitmaps et les
; bitvector sous forme compresse'e (en repe'rant les re'pe'titions de
; caracte`res et de lignes.
; et de lignes).
; 
; Exemple:
; 
; #B(40 4 #[#*0000000000
;           #*0000000000
;           #*0000000000
;           #*a5a5a5f3f3])
; 
; s'affichera en mode compresse' :
; 
; #B(40 4 #[#5*00*4
;           2
;           #5*a5*3f3f3])    
; 
; 
; La #-macro *, permet de lire le mode normal ou le mode compresse'.
; Si l'argument nume'rique est fourni, il s'agit du mode compresse',
; s'il ne l'est pas c'est le mode in-extenso.
; 
; De me^me #:BITMAP:BITS de'code le mode compresse', on pourra donc
; e'crire, par exemple: 
; 
; #B(1000 1000 #[*#aa*fd 999])
; 
; ou bien :
; 
; #B(1000 1000 #[*125#aa*fd 999])
; 
; 
; 
; Le format compresse' des BITVECTORs :
; 
;                      Internal                          External
; 
; Nible                0000 xxxx   0000 yyyy             0-9 A-F
; Predefined Byte      0001 xxxx                         G-V
; Small rep-factor     0010 xxxx                         a-p
; Large rep-factor     0011 0xxx   00yy yyyy             q-x
; 
; Terminal 0s          0011 1110                         +
; User rep-factor      0011 1111   0000 xxxx 0000 yyyy   * <h> <h>
; ExtraCode (not used) 0011 1xxx                         yzWXYZ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar :int->ext-encode-string
  "0123456789ABCDEFGHIJKLMNOPQRSTUVabcdefghijklmnopqrstuvwxyzWXYZ+*")

(defvar :ext->int-encode-string
  (let ((strg-buffer (makestring 128 #$FF)))
    (for (strg-index 0 1 (1- (slength :int->ext-encode-string)))
         (sset strg-buffer
               (sref :int->ext-encode-string strg-index)
               strg-index))
    strg-buffer))

(defvar :predefined-bytes
  (let ((strg-buffer (makestring 16 0)))
    (sset strg-buffer 00  #$00)
    (sset strg-buffer 01  #$FF)
    (sset strg-buffer 02  #$01)
    (sset strg-buffer 03  #$02)
    (sset strg-buffer 04  #$04)
    (sset strg-buffer 05  #$08)
    (sset strg-buffer 06  #$10)
    (sset strg-buffer 07  #$20)
    (sset strg-buffer 08  #$40)
    (sset strg-buffer 09  #$80)
    (sset strg-buffer 10  #$44)
    (sset strg-buffer 11  #$55)
    (sset strg-buffer 12  #$AA)
    (sset strg-buffer 13  #$11)
    (sset strg-buffer 14  #$C0)
    (sset strg-buffer 15  #$03)
    strg-buffer))

(unless (boundp '#:system:compressed-icon)
        (defvar #:system:compressed-icon))

(defmacro :round-to-byte (n)
  `(logshift (add ,n 7) -3))

(defmacro :int->ext-encode (current-byte)
  `(sref :int->ext-encode-string ,current-byte))

(de :ext->int-encode (current-byte)
    (let ((code (sref :ext->int-encode-string (logand current-byte #$7F))))
      (if (neq code #$FF)
          code
        (error '|#*| 'errsxt (list current-byte)))))

(de #:bitvector:read (strg-size strg-buffer)  
    (if (fixp strg-size)
        (let ((previous-byte 0)
              (current-byte)
              (strg-index 0))
          (setq strg-buffer (makestring strg-size 0))
          (while (lt strg-index strg-size)
	    (setq current-byte (:ext->int-encode (readcn)))
	    (cond ((le current-byte  #$F)
		   ; le format "double nibble" complet.
		   (setq previous-byte
			 (logor (logshift current-byte 4)
				(:ext->int-encode (readcn))))
		   (sset strg-buffer strg-index previous-byte)
		   (setq strg-index (add1 strg-index)))
		  ((le current-byte #$1F)
		   ; le format des caracte`res pre'de'finis
		   (setq previous-byte (sref :predefined-bytes
					     (logand current-byte #$F)))
		   (sset strg-buffer strg-index previous-byte)
		   (setq strg-index (add1 strg-index)))
		  ((le current-byte #$3F)
		   ; les re'pe'titeurs en tous genres.
		   (repeat (add1 (cond ((le current-byte #$2F)
					; petits re'pe'titeurs
					(logand current-byte #$F))
				       ((lt current-byte #$3E)
					; grands re'pe'titeurs
					(logor (logshift (logand current-byte
								 #$F)
							 6)
					       (:ext->int-encode (readcn))))
				       ((eq current-byte #$3E)
					; re'pe'titeur terminal de 0 : "+"
					(setq strg-index strg-size)
					-1)
				       ((eq current-byte #$3F)
					; re'pe'titeur utilisateur : "*"
					(logor (logshift (:ext->int-encode
                                                          (readcn))
							 4)
					       (:ext->int-encode (readcn))))))
			   (sset strg-buffer strg-index previous-byte)
			   (setq strg-index (add1 strg-index))))
		  (t (error "#*"  'errsxt current-byte)))))
      (let ((current-list ()))
        (untilexit complete
                   (newl current-list
                         (logor (logshift (:conv-to-hex (peekcn)) 4)
                                (progn (readcn)
                                       (:conv-to-hex (readcn))))))
        (setq strg-buffer (string (nreverse current-list)))))
    (typestring strg-buffer 'bitvector)
    strg-buffer)

(de :conv-to-hex (char)
    (cond ((and (ge char #/0) (le char #/9))
	   (sub char #/0))
	  ((and (ge char #/A) (le char #/F))
	   (sub char #.(- #/A 10)))
	  ((and (ge char #/a) (le char #/f))
	   ; a` cause que parfois ....
	   (sub char #.(- #/a 10)))
	  (t (exit complete))))

(de #:bitvector:prin (bitvector)
    ;; impression d'un vecteur de bits
    (let ((strg-size (slen bitvector))
	  (strg-index 0)
	  (current-byte))
      (let ((#:system:print-for-read ()))
	(if #:system:compressed-icon
	    ; ce code est faux en cas de coupure de ligne.
	    ; mais en mode print-for-read+compressed-icon
	    ; un terpri est re'alise' entre chaque ligne.
	    (prin "#" strg-size "*")
          (prin "#*")))
      (if #:system:compressed-icon
	  (let ((previous-byte -1)
		(rep-factor 0))
            (while (neq strg-index strg-size)
              (setq current-byte (sref bitvector strg-index))
              (if (eq current-byte previous-byte)
                  (setq rep-factor (add1 rep-factor))
                (progn
                  (:prin-aux previous-byte rep-factor)
                  (setq rep-factor 0)
                  (setq previous-byte current-byte)))
              (setq strg-index (add1 strg-index)))
            (if (and (eq previous-byte 0)
                     (neq rep-factor 0))
                (princn (:int->ext-encode 62))
              (:prin-aux previous-byte rep-factor)))
        (repeat strg-size
                (setq current-byte (sref bitvector strg-index))
                (princn (:int->ext-encode (logshift current-byte -4)))
                (princn (:int->ext-encode (logand current-byte #$F)))
                (setq strg-index (add1 strg-index))))))    

(de :prin-aux (byte rep-factor)
    ;; imprime l'octet <byte> avec un facteur de re'pe'tition <rep-factor>
    (when (neq byte -1)
	  ; pour faciliter le de'marrage de la boucle
	  (let ((index-byte (chrpos byte :predefined-bytes)))
            (if index-byte
                ; c'est un octet pre'de'fini
                (princn (:int->ext-encode (add #$10 index-byte)))
              (progn
                ; c'est un octet a` 2 nibles
                (princn (:int->ext-encode (logshift byte -4)))
                (princn (:int->ext-encode (logand byte #$F)))))))
    (when (neq rep-factor 0)
	  ; les facteurs de re'pe'titions partent a` 0
	  (setq rep-factor (sub1 rep-factor))
	  (if (lt rep-factor 16)
	      ; facteur de re'pe'tition sur 1 octet
	      (princn (:int->ext-encode (add rep-factor #$20)))
            (progn
              ; facteur de re'pe'tition sur 2 octets.
              (princn (:int->ext-encode (add (logshift rep-factor -6) #$30)))
              (princn (:int->ext-encode (logand rep-factor #$3F)))))))

(de #:bitmap:prin (bitmap)
    (let ((hbitmap (:h bitmap))
	  (wbitmap (:w bitmap)))
      (let ((#:system:print-for-read ()))
        (prin "#B("  wbitmap " " hbitmap " #["))
      (when #:system:print-for-read
	    (with ((rmargin (add1 (slen (outbuf)))))
		  (terpri)
		  (let* ((bbitmap   (:round-to-byte wbitmap))
			 (bitvect1  (makestring bbitmap 0))
			 (bitvect2  (makestring bbitmap -1))
			 (indmax    (sub1 bbitmap))
			 (last-bits (logand wbitmap 7))
			 (mask      (logshift #$FF (sub 8 last-bits)))
			 (line-index 0)
			 (rep-factor 0))
		    (typestring bitvect1 'bitvector)
		    (typestring bitvect2 'bitvector)
		    (repeat hbitmap
			    (send 'get-bit-line (:display bitmap)
                                  bitmap line-index bitvect1)
			    (setq line-index (add1 line-index))
			    (when (neq last-bits 0)
				  (sset bitvect1
					indmax
					(logand (sref bitvect1 indmax) mask)))
			    (if (and #:system:compressed-icon
				     (equal bitvect1 bitvect2)
				     (neq line-index 0))
				(setq rep-factor (add1 rep-factor))
                              (progn
                                (when (neq rep-factor 0)
                                      (print rep-factor))
                                (print bitvect1)
                                ; l'e'change de HackMem
                                (setq bitvect2 (prog1 bitvect1
                                                 (setq bitvect1 bitvect2)))
                                (setq rep-factor 0))))
		    (when (neq rep-factor 0)
			  (print rep-factor)))))
      (princn #/])
      (princn #/) ))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;