;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Globales ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar #:sys-package:bitmap '#:display:x11)

(defvar #:sys-package:colon #:sys-package:bitmap)

(unless (boundp 'errnomorecolors)
        (defvar errnomorecolors
          #- #:system:foreign-language "plus de couleurs disponibles"
          #+ #:system:foreign-language "no more colors available"))

(unless (boundp ':file-descriptor-mask) (defvar :file-descriptor-mask 0))

(unless (boundp ':events-list) (defvar :events-list))

(unless (boundp ':override-redirect) (defvar :override-redirect))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Les structures ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct #:display:x11 
  (file-descriptor 0)
  events-in-socket
  reread
  drawing-flag
  events-list
  function-keys
  line-style-vector
  pattern-vector
  cursor-vector
  font-vector
  mode-vector)

(defstruct #:x11:extend
  view-rect
  offset-x
  offset-y
  visible
  xwindow
  xgraph-env)

(defstruct #:x11:bitmap
  window
  xbitmap)

(defstruct #:x11:menu
  invertedx
  invertedy
  window)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;; References C ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defextern |_initialise| (t t t))
(defextern |_bitprologue| (string fix fix t t t) external)
(defextern |_init_pixels| (external fix fix fix))
(defextern |_bitepilogue| (external))
(defextern |_bitmap_flush| (external))
(defextern |_bitmap_sync| (external))
(defextern |_bitmap_refresh| (external external))
(defextern |_root_window| (external) external)
(defextern |_current_window| (external external external fix fix))
(defextern |_pop_window| (external external))
(defextern |_move_behind_window| (external external))
(defextern |_kill_window| (external external external))
(defextern |_find_window| (external fix fix) t)
(defextern |_map_window| (external external fix fix t t))
(defextern |_eventp| (external) t)
(defextern |_flush_event| (external))
(defextern |_grab_event| (external external))
(defextern |_ungrab_event| (external))
(defextern |_read_event| (external vector) t)
(defextern |_peek_event| (external vector) t)
(defextern |_read_mouse| (external vector))
(defextern |_current_clip| (external external fix fix fix fix))
(defextern |_current_font| (external external))
(defextern |_load_font| (external string) external)
(defextern |_draw_cn| (external fix fix fix fix))
(defextern |_draw_string| (external fix fix string fix fix fix))
(defextern |_width_string| (external string fix fix) fix)
(defextern |_height_string| (external string fix fix) fix)
(defextern |_x_base_string| (external string fix fix) fix)
(defextern |_y_base_string| (external string fix fix) fix)
(defextern |_clear_graph_env| (external fix fix fix fix))
(defextern |_current_line_style| (external fix fix))
(defextern |_current_mode| (external fix))
(defextern |_current_pattern| (external external))
(defextern |_draw_point| (external fix fix))
(defextern |_draw_polymarker| (external fix vector vector))
(defextern |_draw_line| (external fix fix fix fix))
(defextern |_draw_rectangle| (external fix fix fix fix))
(defextern |_draw_ellipse| (external fix fix fix fix))
(defextern |_draw_polyline| (external fix vector vector))
(defextern |_fill_rectangle| (external fix fix fix fix fix))
(defextern |_fill_ellipse| (external fix fix fix fix fix))
(defextern |_fill_area| (external fix vector vector fix))
(defextern |_create_bitmap| (external fix fix) external)
(defextern |_kill_bitmap| (external external))
(defextern |_get_bit_line| (external external fix fix string fix))
(defextern |_set_bit_line| (external external fix fix string fix))
(defextern |_bmref| (external external fix fix) fix)
(defextern |_bmset| (external external fix fix fix))
(defextern |_default_gc| (external) external)
(defextern |_pixmap_to_bitmap| (external external fix fix) external)
(defextern |_current_cursor| (external external))
(defextern |_create_cursor| (external fix) external)
(defextern |_move_cursor| (external fix fix))
(defextern |_make_color| (external fix fix fix vector) fix)
(defextern |_make_mutable_color| (external fix fix fix) fix)
(defextern |_make_named_color| (external string vector) fix)
(defextern |_kill_color| (external fix))
(defextern |_current_foreground| (external fix))
(defextern |_current_background| (external fix))
(defextern |_color_component| (external fix fix fix fix fix) t)
(defextern |_get_default| (external string string) string)
(defextern |_activate_window| (external external))
(defextern |_bitblit|
  (external external external fix fix fix fix fix fix external))
(defextern |_create_graph_env|
  (external external external fix fix external fix) external)
(defextern |_create_window|
  (external t fix fix fix fix string fix fix external) external)
(defextern |_create_subwindow|
  (external t fix fix fix fix fix external) external)
(defextern |_modify_window|
  (external external fix fix fix fix fix fix fix fix string fix fix fix fix))
(defextern |_make_cursor| 
  (external external external fix fix fix fix fix fix fix fix) external)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;; Fonctions relatives a` l'affichage ;;;;;;;;;;;;;;;;;;;;;;;;

(unless (boundp ':xmax) (defvar :xmax))
(unless (boundp ':ymax) (defvar :ymax))
(unless (boundp ':fd)   (defvar :fd))

(de :bitprologue (display)
    (let ((:xmax 0) (:ymax 0) (:fd 0))
      (unless (#:display:prologuep display)
              (unless (#:display:device display)
                      (#:display:device display (getenv "DISPLAY"))
                      (unless (#:display:device display)
                              (error ':bitprologue
                                     "unbound shell variable" "DISPLAY")))
              (:initialise display)
              (:xdisplay display
                         (|_bitprologue| (catenate (#:display:device display))
					 (:event-mask display)
                                         (if :override-redirect 1 0)
                                         ':xmax ':ymax ':fd))
              (#:display:xmax display :xmax)
              (#:display:ymax display :ymax)
              (:init-color display)
              (:init-cursor display)
              (:init-font display)
              (:init-line-style display)
              (:init-pattern display)
              (:init-window display)
              (:init-file-descriptor display :fd)
              (:reread display ())
              display)))

(de :bitepilogue (display)
    (when (#:display:prologuep display)
          (:font-vector display ())
          (:line-style-vector display ())
          (:pattern-vector display ())
          (:mode-vector display ())
          (:cursor-vector display ())
          (:reread display ())
          (:drawing-flag display ())
          (:function-keys display ())
          (:reread display ())
          (setq :file-descriptor-mask 
                (logxor :file-descriptor-mask 
                        (2** (:file-descriptor display))))
          (:file-descriptor display 0)
          (:events-in-socket display ())
          (|_bitepilogue| (:xdisplay display))))

(de :bitmap-save (display)
    (:bitepilogue display))

(de :bitmap-restore (display)
    (:bitprologue display))

(de :bitmap-refresh (display)
    (|_bitmap_refresh| (:xdisplay display) 
                       (vref (:cursor-vector display) 
                             (#:window:cursor (#:display:window display)))))

(de :bitmap-flush (display)
    (|_bitmap_flush| (:xdisplay display)))

(de :bitmap-sync (display)
    (|_bitmap_sync| (:xdisplay display)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Fonctions defauts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de :standard-roman-font (display) 0)

(de :standard-bold-font (display) 1)

(de :large-roman-font (display) 2)

(de :small-roman-font (display) 3)

(de :standard-background-pattern (display) 0)

(de :standard-foreground-pattern (display) 1)

(de :standard-medium-gray-pattern (display) 2)

(de :standard-light-gray-pattern (display) 3)

(de :standard-dark-gray-pattern (display) 4)

(de :standard-lelisp-cursor (display) 0)

(de :standard-gc-cursor (display) 1)

(de :standard-busy-cursor (display) 2)

;;;;;;;;;;;;;;;;;;;;;;;;; Fonctions d'initialisation ;;;;;;;;;;;;;;;;;;;;;;;;;;

(de :initialise (display)
    (:function-keys display
                    '((#$FF08 . BackSpace)
                      (#$FF09 . Tab)
                      (#$FF0A . Linefeed)
                      (#$FF0B . Clear)
                      (#$FF0D . Return)
                      (#$FF13 . Pause)
                      (#$FF1B . Escape)
                      (#$FFFF . Delete)
                      (#$FF20 . Multi-key)
                      (#$FF21 . Kanji)
                      (#$FF50 . Home)
                      (#$FF51 . Left)
                      (#$FF52 . Up)
                      (#$FF53 . Right)
                      (#$FF54 . Down)
                      (#$FF55 . Prior)
                      (#$FF56 . Next)
                      (#$FF57 . End)
                      (#$FF58 . Begin)
                      (#$FF60 . Select)
                      (#$FF61 . Print)
                      (#$FF62 . Execute)
                      (#$FF63 . Insert)
                      (#$FF65 . Undo)
                      (#$FF66 . Redo)
                      (#$FF67 . Menu)
                      (#$FF68 . Find)
                      (#$FF69 . Cancel)
                      (#$FF6A . Help)
                      (#$FF6B . Break)
                      (#$FF7E . Mode-switch)
                      (#$FF7E . script-switch)
                      (#$FF7F . Num-Lock)
                      (#$FF80 . KP-Space)
                      (#$FF89 . KP-Tab)
                      (#$FF8D . KP-Enter)
                      (#$FF91 . KP-F1)
                      (#$FF92 . KP-F2)
                      (#$FF93 . KP-F3)
                      (#$FF94 . KP-F4)
                      (#$FFBD . KP-Equal)
                      (#$FFAA . KP-Multiply)
                      (#$FFAB . KP-Add)
                      (#$FFAC . KP-Separator)
                      (#$FFAD . KP-Subtract)
                      (#$FFAE . KP-Decimal)
                      (#$FFAF . KP-Divide)
                      (#$FFB0 . KP-0)
                      (#$FFB1 . KP-1)
                      (#$FFB2 . KP-2)
                      (#$FFB3 . KP-3)
                      (#$FFB4 . KP-4)
                      (#$FFB5 . KP-5)
                      (#$FFB6 . KP-6)
                      (#$FFB7 . KP-7)
                      (#$FFB8 . KP-8)
                      (#$FFB9 . KP-9)
                      (#$FFBE . F1)
                      (#$FFBF . F2)
                      (#$FFC0 . F3)
                      (#$FFC1 . F4)
                      (#$FFC2 . F5)
                      (#$FFC3 . F6)
                      (#$FFC4 . F7)
                      (#$FFC5 . F8)
                      (#$FFC6 . F9)
                      (#$FFC7 . F10)
                      (#$FFC8 . F11)
                      (#$FFC8 . L1)
                      (#$FFC9 . F12)
                      (#$FFC9 . L2)
                      (#$FFCA . F13)
                      (#$FFCA . L3)
                      (#$FFCB . F14)
                      (#$FFCB . L4)
                      (#$FFCC . F15)
                      (#$FFCC . L5)
                      (#$FFCD . F16)
                      (#$FFCD . L6)
                      (#$FFCE . F17)
                      (#$FFCE . L7)
                      (#$FFCF . F18)
                      (#$FFCF . L8)
                      (#$FFD0 . F19)
                      (#$FFD0 . L9)
                      (#$FFD1 . F20)
                      (#$FFD1 . L10)
                      (#$FFD2 . F21)
                      (#$FFD2 . R1)
                      (#$FFD3 . F22)
                      (#$FFD3 . R2)
                      (#$FFD4 . F23)
                      (#$FFD4 . R3)
                      (#$FFD5 . F24)
                      (#$FFD5 . R4)
                      (#$FFD6 . F25)
                      (#$FFD6 . R5)
                      (#$FFD7 . F26)
                      (#$FFD7 . R6)
                      (#$FFD8 . F27)
                      (#$FFD8 . R7)
                      (#$FFD9 . F28)
                      (#$FFD9 . R8)
                      (#$FFDA . F29)
                      (#$FFDA . R9)
                      (#$FFDB . F30)
                      (#$FFDB . R10)
                      (#$FFDC . F31)
                      (#$FFDC . R11)
                      (#$FFDD . F32)
                      (#$FFDD . R12)
                      (#$FFDE . R13)
                      (#$FFDE . F33)
                      (#$FFDF . F34)
                      (#$FFDF . R14)
                      (#$FFE0 . F35)
                      (#$FFE0 . R15)
                      (#$FFE1 . Shift-L)
                      (#$FFE2 . Shift-R)
                      (#$FFE3 . Control-L)
                      (#$FFE4 . Control-R)
                      (#$FFE5 . Caps-Lock)
                      (#$FFE6 . Shift-Lock)
                      (#$FFE7 . Meta-L)
                      (#$FFE8 . Meta-R)
                      (#$FFE9 . Alt-L)
                      (#$FFEA . Alt-R)
                      (#$FFEB . Super-L)
                      (#$FFEC . Super-R)
                      (#$FFED . Hyper-L)
                      (#$FFEE . Hyper-R)))
    (|_initialise| () 'errx 'error))

(de :event-mask (display)
    (let ((events :events-list))
      (cond ((null events)
             (setq events (list 'ascii-event 'functionkey-event
                                'down-event 'up-event
                                'move-event 'drag-event
                                'enterwindow-event 'leavewindow-event)))
            ((and (memq 'move-event events)
                  (not (memq 'drag-event events)))
             (setq events (newr events 'drag-event))))
      (:events-list display events)
      (let ((mask 0))
        (while events
          (selectq (nextl events)
                   (ascii-event (setq mask (logor mask 1)))            
                   (functionkey-event (setq mask (logor mask 1))) 
                   (down-event  (setq mask (logor mask 4)))            
                   (up-event    (setq mask (logor mask 8)))            
                   (enterwindow-event (setq mask (logor mask 16)))            
                   (leavewindow-event (setq mask (logor mask 32)))
                   (drag-event (setq mask (logor mask 8192)))
                   (move-event (setq mask (logor mask 64)))
                   (t ())))
        mask)))

(de :init-font (display)
    (:font-vector display #[])
    (:add-a-font display "font" "vtsingle")
    (:add-a-font display "attributefont" "vtbold")
    (:add-a-font display "smallfont" "6x10")
    (:add-a-font display "largefont" "swd-s30"))

(de :add-a-font (display item default)
    (let ((name (|_get_default| (:xdisplay display) "lelisp" item)))
      (when (eq 0 (slen name))
            (setq name default))
      (#:display:font-names display
                            (acons name
                                   (:load-font display
                                               (#:display:graph-env display)
                                               name)
                                   (#:display:font-names display)))))
                                             
(de :init-line-style (display)
    (:line-style-vector display
                        #[#[0 0] #[1 0] #[1 1] #[1 2] #[2 0] #[2 1] #[2 2]]))

(de :init-pattern (display)
    (:pattern-vector display #[])
    (:add-a-pattern display 16 16
                   #[#*0000 #*0000 #*0000 #*0000
                   #*0000 #*0000 #*0000 #*0000
                   #*0000 #*0000 #*0000 #*0000
                   #*0000 #*0000 #*0000 #*0000])
    (:add-a-pattern display 16 16
                   #[#*ffff #*ffff #*ffff #*ffff
                   #*ffff #*ffff #*ffff #*ffff
                   #*ffff #*ffff #*ffff #*ffff
                   #*ffff #*ffff #*ffff #*ffff])
    (:add-a-pattern display 16 16
                   #[#*aaaa #*5555 #*aaaa #*5555
                   #*aaaa #*5555 #*aaaa #*5555
                   #*aaaa #*5555 #*aaaa #*5555
                   #*aaaa #*5555 #*aaaa #*5555])
    (:add-a-pattern display 16 16
                   #[#*8888 #*2222 #*8888 #*2222
                   #*8888 #*2222 #*8888 #*2222
                   #*8888 #*2222 #*8888 #*2222
                   #*8888 #*2222 #*8888 #*2222])
    (:add-a-pattern display 16 16
                   #[#*7777 #*dddd #*7777 #*dddd
                   #*7777 #*dddd #*7777 #*dddd
                   #*7777 #*dddd #*7777 #*dddd
                   #*7777 #*dddd #*7777 #*dddd]))

(de :add-a-pattern (display w h bits)
    (let ((bitmap (#:bitmap:make)))
      (#:bitmap:w bitmap w)
      (#:bitmap:h bitmap h)
      (#:bitmap:display bitmap display)
      (:create-bitmap display bitmap)
      (#:bitmap:bits bitmap bits)
      (:make-pattern display (#:display:graph-env display) bitmap)))

(de :init-cursor (display)
    (:cursor-vector display #[0 0 0])
    (let ((lelispcursor (|_get_default| (:xdisplay display) "lelisp" "cursor"))
          (gccursor (|_get_default| (:xdisplay display) "lelisp" "gccursor"))
          (busycursor
           (|_get_default| (:xdisplay display) "lelisp" "busycursor")))
      (if (eqstring lelispcursor "")
          (setq lelispcursor 68)
        (setq lelispcursor (implode (explode lelispcursor))))
      (if (eqstring gccursor "")
          (setq gccursor 88)
        (setq gccursor (implode (explode gccursor))))
      (if (eqstring busycursor "")
          (setq busycursor 82)
        (setq busycursor (implode (explode busycursor))))
      (vset (:cursor-vector display) 
            0 (|_create_cursor| (:xdisplay display) lelispcursor))
      (vset (:cursor-vector display) 
            1 (|_create_cursor| (:xdisplay display) gccursor))
      (vset (:cursor-vector display)
            2 (|_create_cursor| (:xdisplay display) busycursor)))
    (#:display:cursor-bitmaps display ()))

(de :init-color (display)
    (let ((forename (|_get_default| (:xdisplay display) "lelisp" "foreground"))
          (backname (|_get_default| (:xdisplay display) "lelisp" "background"))
          (lelispreversevideo
           (|_get_default| (:xdisplay display) "lelisp" "reversevideo"))
          (fore (#:color:make))
          (back (#:color:make))
          planemask)
      (when (eqstring forename "")
            (setq forename "black"))
      (when (eqstring backname "")
            (setq backname "white"))
      (when (eqstring lelispreversevideo "on")
            (setq forename "white"
                  backname "black"))
      (#:color:name fore forename)
      (#:color:display fore display)
      (:make-named-color display fore forename)
      (#:color:name back backname)
      (#:color:display back display)
      (:make-named-color display back backname)
      (#:display:foreground display fore)
      (#:display:background display back)
      (#:display:colors display (list fore back))
      (setq planemask
            (if (eq (#:color:extend fore) (#:color:extend back))
                1
              (:compute-mask (#:color:extend fore) (#:color:extend back) 1)))
      (|_init_pixels|
       (:xdisplay display)
       (#:color:extend fore) (#:color:extend back) planemask)
      (if (neq 0 (logand (#:color:extend fore) planemask))
          (:mode-vector display #[0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15])
        (:mode-vector display #[15 7 11 3 13 5 9 1 14 6 10 2 12 4 8 0]))))

(de :compute-mask (p1 p2 m)
    (if (neq (logand p1 m) (logand p2 m))
        m
        (:compute-mask p1 p2 (logshift m 1))))

(de :init-window (display)
    (let ((root (#:window:make))
	  (extend (#:x11:extend:make))
          ge)
      (#:window:left root 0)
      (#:window:top root 0)
      (#:window:width root (#:display:xmax display))
      (#:window:height root (#:display:ymax display))
      (#:window:title root "root-window")
      (#:window:hilited root 0)
      (#:window:visible root 1)
      (#:window:display root display)
      (#:window:extend root extend)
      (:xwindow root (|_root_window| (:xdisplay display)))
      (:create-graph-env display root)
      (setq ge (#:window:graph-env root))
      (#:display:root-window display root)
      (#:display:main-graph-env display ge)
      (#:graph-env:foreground ge (#:display:foreground display))
      (#:graph-env:background ge (#:display:background display))
      (#:display:window display ())
      (#:display:windows display (list root))
      (#:display:graph-env display (#:display:main-graph-env display))
      ))

(de :init-file-descriptor (display fd)
    (setq :file-descriptor-mask 
          (logor :file-descriptor-mask (2** (:file-descriptor display fd)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;; Fonctions sur les fenetres ;;;;;;;;;;;;;;;;;;;;;;;;;;

(de :create-window (display win)
    (let ((x (#:window:left win))
          (y (#:window:top win))
          (w (#:window:width win))
          (h (#:window:height win))
          (ti (#:window:title win))
          (hi (#:window:hilited win))
          (vi (#:window:visible win))
          (cu (vref (:cursor-vector display) (#:window:cursor win))))
      (#:window:extend win (#:x11:extend:make))
      (:xwindow win (|_create_window| (:xdisplay display)
                                       win x y w h (string ti) 
                                       (or (eq hi 1) 0)
                                       vi cu))
      (send 'set-window-hints win)
      (if (eq vi 1) (|_activate_window| (:xdisplay display) (:xwindow win)))
      (:create-graph-env display win)
      win))

(de :create-subwindow (display win)
    (let ((x (#:window:left win))
          (y (#:window:top win))
          (w (#:window:width win))
          (h (#:window:height win))
          (vi (#:window:visible win))
          (father (#:window:father win)))
      (#:window:extend win (#:x11:extend:make))
      (:xwindow win (|_create_subwindow| (:xdisplay display)
                                         win x y w h vi (:xwindow father)))
      (:create-graph-env display win)
      win))

(de :current-window (display win)
    (:drawing-flag display (:visible win))
    (|_current_window| (:xdisplay display)
                       (:xwindow (:top-window win))
                       (:xgraph-env win)
                       (:offset-x win)
                       (:offset-y win)))

(de :uncurrent-window (display win)
    (:drawing-flag display ()))

(de :modify-window (display win x y w h title hilited visible)
    (when x (#:window:left win x))
    (when y (#:window:top win y))
    (when w (#:window:width win w))
    (when h (#:window:height win h))
    (when title (#:window:title win title))
    (when hilited (#:window:hilited win hilited))
    (when visible (#:window:visible win visible))
    (|_modify_window| (:xdisplay display)
                      (:xwindow win)
                      (if (or x y) 1 0)
                      (#:window:left win)
                      (#:window:top win)
                      (if (or w h) 1 0) 
                      (#:window:width win)
                      (#:window:height win)
                      (if (#:window:father win) 0 1)
                      (if title 1 0)
                      (#:window:title win)
                      (if hilited 1 0)
                      (#:window:hilited win)
                      (if visible 1 0)
                      (#:window:visible win))
    (:set-clip-for-subwindows display win)
    (when (eq win (#:display:window display))
          (:current-window display win))
    (send 'modify-window-hints win))

(de :update-window (display win x y w h)
    (when x (#:window:left win x))
    (when y (#:window:top win y))
    (when w (#:window:width win w))
    (when h (#:window:height win h))
    (:set-clip-for-subwindows display win)
    (when (eq win (#:display:window display))
          (:current-window display win))
    (send 'modify-window-hints win))

(de :kill-window (display win)
    (|_kill_window| (:xdisplay display) (:xwindow win) (:xgraph-env win))
    (:xwindow win ())
    (:xgraph-env win ()))

(de :pop-window (display win)
    (|_pop_window| (:xdisplay display) (:xwindow win)))

(de :move-behind-window (display win1 win2)
    (|_move_behind_window| (:xdisplay display) (:xwindow win1)))

(de :current-keyboard-focus-window (display win))

(de :uncurrent-keyboard-focus-window (display win))

(de :find-window (display x y)
    (|_find_window| (:xdisplay display) x y))

(de :map-window (display win :x :y :lx :ly)
    (|_map_window| (:xdisplay display) (:xwindow win) :x :y :lx :ly))

(de #:image:rectangle:window:set-window-hints (window))

(de #:image:rectangle:window:modify-window-hints (window))

;;;;;;;;;;;;;;;;;;;;;;; Fonctions utilitaires ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de :create-graph-env (display win)
    (let ((ge (#:graph-env:make)))
      (#:window:graph-env win ge)
      (#:graph-env:pattern ge 1)
      (#:graph-env:clip-x ge 0)
      (#:graph-env:clip-y ge 0)
      (#:graph-env:clip-w ge (#:window:width win))
      (#:graph-env:clip-h ge (#:window:height win))
      (when (#:display:main-graph-env display)
            (#:graph-env:foreground ge 
                                    (#:graph-env:foreground
                                     (#:display:main-graph-env display)))
            (#:graph-env:background ge 
                                    (#:graph-env:background
                                     (#:display:main-graph-env display))))
      (#:graph-env:display ge display)
      (#:graph-env:extend ge (#:window:extend win))
      (let ((font (vref (:font-vector display) (#:graph-env:font ge)))
            (line-style (vref (:line-style-vector display)
                              (#:graph-env:line-style ge)))
            (pattern (vref (:pattern-vector display) (#:graph-env:pattern ge)))
            (mode (vref (:mode-vector display) (#:graph-env:mode ge))))
        (:xgraph-env win (|_create_graph_env| (:xdisplay display)
                                              (:xwindow (:top-window win))
                                              font
                                              (vref line-style 0)
                                              (vref line-style 1)
                                              pattern
                                              mode)))
      (:view-rect ge (#:image:rectangle:make))
      (:set-clip-for-window display win)
      ge))

(de :set-offsets (win)
    (let ((father (#:window:father win)))
      (:offset-x win (if father
                         (add (#:window:left win) (:offset-x father))
                       0))
      (:offset-y win (if father
                         (add (#:window:top win) (:offset-y father))
                       0))))

(de :set-view-rectangle (win)
    (let* ((ge (#:window:graph-env win))
           (fa (#:window:father win))
           (rect (:view-rect ge)))
      (#:image:rectangle:x rect 0)
      (#:image:rectangle:y rect 0)
      (#:image:rectangle:w rect (#:window:width win))
      (#:image:rectangle:h rect (#:window:height win))
      (:view-rect ge (:intersect rect
                                 (#:graph-env:clip-x ge)
                                 (#:graph-env:clip-y ge)
                                 (#:graph-env:clip-w ge)
                                 (#:graph-env:clip-h ge)))
      (when fa
            (:view-rect ge
                        (:intersect rect
                                    (sub (#:image:rectangle:x 
                                          (:view-rect (#:window:graph-env fa)))
                                         (#:window:left win))
                                    (sub (#:image:rectangle:y 
                                          (:view-rect (#:window:graph-env fa)))
                                         (#:window:top win))
                                    (#:image:rectangle:w 
                                     (:view-rect (#:window:graph-env fa)))
                                    (#:image:rectangle:h 
                                     (:view-rect (#:window:graph-env fa))))))))

(de :set-visibility (win)
    (let ((father (#:window:father win))
          (viewrect (:view-rect (#:window:graph-env win))))
      (:visible win (if father 
                        (and (:visible father)
                             (eq 1 (#:window:visible win))
                             (gt (#:image:rectangle:w viewrect) 0)
                             (gt (#:image:rectangle:h viewrect) 0))
                      (eq 1 (#:window:visible win))))))

(de :set-clip-for-subwindows (display win)
    (:set-clip-for-window display win)
    (mapc (lambda (w) (:set-clip-for-subwindows display w))
          (#:window:subwindows win)))

(de :set-clip-for-window (display win)
    (:set-offsets win)
    (:set-view-rectangle win)
    (:set-visibility win)
    (let ((ge (#:window:graph-env win)))
      (|_current_clip| (:xdisplay display)
                       (:xgraph-env win)
                       (add (#:image:rectangle:x (:view-rect ge))
                            (:offset-x win))
                       (add (#:image:rectangle:y (:view-rect ge))
                            (:offset-y win))
                       (#:image:rectangle:w (:view-rect ge))
                       (#:image:rectangle:h (:view-rect ge))))) 

(de :intersect (rect x y w h)
    (let ((x0 (#:image:rectangle:x rect))
          (y0 (#:image:rectangle:y rect))
          (w0 (#:image:rectangle:w rect))
          (h0 (#:image:rectangle:h rect))
          (u (add x w))
          (v (add y h)))
      (#:image:rectangle:x rect (or (gt x0 x) x)) 
      (#:image:rectangle:y rect (or (gt y0 y) y)) 
      (#:image:rectangle:w rect (sub (or (lt (add x0 w0) u) u)
                                     (#:image:rectangle:x rect)))
      (#:image:rectangle:h rect (sub (or (lt (add y0 h0) v) v)
                                     (#:image:rectangle:y rect)))
      rect))

(de :top-window (win)
    (if (#:window:father win)
        (:top-window (#:window:father win))
      win))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;; Fonctions sur les evenements ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de :event-mode (display mode))

(de :flush-event (display)
    (:reread display ())
    (|_flush_event| (:xdisplay display))
    (:events-in-socket display ()))

(de :eventp (display)
    (or (:reread display)
        (|_eventp| (:xdisplay display))
        (:events-in-socket display)))

(de :read-event (display event)
    (if (:reread display)
        (let ((rereadevent (car (:reread display))))
          (:reread display (cdr (:reread display)))
          (bltvector event 0 rereadevent 0))
      (fillvector event 0 () 9)
      (if (eq 2
              (:events-in-socket display
                                 (|_read_event| (:xdisplay display) event)))
          (:read-event display event)
        (:parse-event display event t))))

(de :peek-event (display event)
    (if (:reread display)
        (bltvector event 0 (car (:reread display)) 0)
      (fillvector event 0 () 9)
      (:events-in-socket display (|_peek_event| (:xdisplay display) event))
      (:parse-event display event ())))

(de :read-mouse (display event)
    (fillvector event 0 () 9)
    (|_read_mouse| (:xdisplay display) event))

(de :add-event (display event)
    (let ((new (makevector (vlength event) ())))
      (bltvector new 0 event 0)
      (:reread display (nconc1 (:reread display) new))))

(de :grab-event (display win)
    (|_grab_event| (:xdisplay display) (:xwindow win)))

(de :ungrab-event (display)
    (|_ungrab_event| (:xdisplay display)))

(de :itsoft-event (display))

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

(de :parse-event (display event readp)
    (selectq (#:event:code event)
             (2
              (when (#:display:keyboard-focus-window display)
                    (#:event:window event
                                    (#:display:keyboard-focus-window display)))
              (#:event:code event (if (memq 'ascii-event
                                            (:events-list display))
                                      'ascii-event
                                    'no-event)))
             (36
              (when (#:display:keyboard-focus-window display)
                    (#:event:window event
                                    (#:display:keyboard-focus-window display)))
              (#:event:detail event
                              (cassq (#:event:detail event)
                                     (:function-keys display)))
              (#:event:code event (if (memq 'functionkey-event
                                            (:events-list display))
                                      'functionkey-event
                                    'no-event)))
             (4
              (#:event:code event 'down-event))
             (5
              (#:event:code event 'up-event))
             (6
              (#:event:code event
                            (if (#:event:detail event)
                                (if (memq 'drag-event (:events-list display))
                                    'drag-event
                                  'no-event)
                              (if (memq 'move-event (:events-list display))
                                  'move-event
                                'no-event))))
             (7
              (#:event:code event 'enterwindow-event))
             (8
              (#:event:code event 'leavewindow-event))
             ((9 10)
              (#:event:detail event (when (eq 9 (#:event:code event)) t))
              (#:event:code event 'keyboard-focus-event))
             (12
              (#:event:code event 'repaint-window-event))
             (17
              (if (windowp (#:event:window event))
                  (#:event:code event 'kill-window-event)
                (#:event:code event 'no-event)))
             (18
              (#:event:code event 'no-event))
             (22
              (let ((window (#:event:window event)))
                (#:event:code
                 event                  
                 (if (or (null window)
                         (and (eq (#:window:left window) (#:event:x event))
                              (eq (#:window:top window) (#:event:y event))
                              (eq (#:window:width window) (#:event:w event))
                              (eq (#:window:height window) (#:event:h event))))
                     'no-event 
                   'modify-window-event))))
             (t
              (#:event:code event 'no-event))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;; Fonctions de l'environnement graphique ;;;;;;;;;;;;;;;;;;

(de :clear-graph-env (display ge)
    (when (:drawing-flag display)
          (let ((rect (:view-rect ge)))
            (|_clear_graph_env| (:xdisplay display)
                                (#:image:rectangle:x rect)
                                (#:image:rectangle:y rect)
                                (#:image:rectangle:w rect)
                                (#:image:rectangle:h rect)))))

(de :current-clip (display ge x y w h)
    (when (#:display:window display)
          (:set-clip-for-subwindows display (#:display:window display))))

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

(de :font-max (display ge)
    (sub1 (vlength (:font-vector display))))

(de :load-font (display ge font)
    (let ((xfont (|_load_font| (:xdisplay display) font))
          (nbfont (vlength (:font-vector display))))
      (if (eq xfont 0)
          (error 'load-font erroob font)
        (:font-vector display
                      (bltvector (makevector (add1 nbfont) 0)
                                 0 (:font-vector display) 
                                 0 nbfont))
        (vset (:font-vector display) nbfont xfont)
        nbfont)))

(de :current-font (display ge font)
    (|_current_font| (:xdisplay display)
                     (vref (:font-vector display) font)))

(de :width-substring (display ge string start length)
    (let* ((slen (slen string))
           (maxle (sub slen start)))
      (ifn (le start slen)
           0
           (when (gt length maxle)
                 (setq length maxle))
           (|_width_string| (vref (:font-vector display) (#:graph-env:font ge))
                            string start length))))

(de :height-substring (display ge string start length)
    (let* ((slen (slen string))
           (maxle (sub slen start)))
      (ifn (lt start slen)
           (setq string " " start 0 length 1)
           (when (gt length maxle)
                 (setq length maxle)))
      (|_height_string| (vref (:font-vector display) (#:graph-env:font ge))
                        string start length)))

(de :x-base-substring (display ge string start length)
    (let* ((slen (slen string))
           (maxle (sub slen start)))
      (ifn (lt start slen)
           (setq string " " start 0 length 1)
           (when (gt length maxle)
                 (setq length maxle)))
      (|_x_base_string| (vref (:font-vector display) (#:graph-env:font ge))
                        string start length)))

(de :y-base-substring (display ge string start length)
    (let* ((slen (slen string))
           (maxle (sub slen start)))
      (ifn (lt start slen)
           (setq string " " start 0 length 1)
           (when (gt length maxle)
                 (setq length maxle)))
      (|_y_base_string| (vref (:font-vector display) (#:graph-env:font ge))
                        string start length)))

(de :x-inc-substring (display ge string start length)
    (:width-substring display ge string start length))

(de :y-inc-substring (display ge string start length)
    0)

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

(de :line-style-max (display ge)
    (sub1 (vlength (:line-style-vector display))))

(de :current-line-style (display ge line-style)
    (let ((style (vref (:line-style-vector display) line-style)))
      (|_current_line_style| (:xdisplay display)
                             (vref style 0) (vref style 1))))

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

(de :pattern-max (display ge)
    (sub1 (vlength (:pattern-vector display))))

(de :make-pattern (display ge bitmap)
    (let ((nbpattern (vlength (:pattern-vector display))))
      (:pattern-vector display
                       (bltvector (makevector (add1 nbpattern) 0)
                                  0 (:pattern-vector display) 
                                  0 nbpattern))
      (vset (:pattern-vector display) nbpattern (:xbitmap bitmap))
      nbpattern))

(de :current-pattern (display ge pattern)
    (|_current_pattern| (:xdisplay display)
                        (vref (:pattern-vector display) pattern)))

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

(de :current-mode (display ge mode)
    (|_current_mode| (:xdisplay display)
                     (vref (:mode-vector display) mode)))

;;;;;;;;;;;;;;;;;;;;;;;;; Fonctions d'affichage ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de :draw-cn (display ge x y cn)
    (when (:drawing-flag display)
          (|_draw_cn| (:xdisplay display) x y cn (current-mode))))

(de :draw-substring (display ge x y string start length)
    (when (:drawing-flag display)
          (let* ((slen (slen string))
                 (maxle (sub slen start)))
            (when (le start slen)
                  (when (gt length maxle) (setq length maxle))
                  (|_draw_string| (:xdisplay display) x y string start length 
	    			  (current-mode))))))

(de :draw-point (display ge x y)
    (when (:drawing-flag display)
          (|_draw_point| (:xdisplay display) x y)))

(de :draw-polymarker (display ge n vx vy)
    (when (:drawing-flag display)
          (|_draw_polymarker| (:xdisplay display) n vx vy)))

(de :draw-line (display ge x0 y0 x1 y1)
    (when (:drawing-flag display)
          (|_draw_line| (:xdisplay display) x0 y0 x1 y1)))

(de :draw-rectangle (display ge x y w h)
    (when (:drawing-flag display)
          (|_draw_rectangle| (:xdisplay display) x y w h)))

(de :draw-polyline (display ge n vx vy)
    (when (:drawing-flag display)
          (|_draw_polyline| (:xdisplay display) n vx vy)))

(de :draw-ellipse (display ge x y rx ry)
    (when (:drawing-flag display)
          (|_draw_ellipse| (:xdisplay display) x y rx ry)))

(de :draw-circle (display ge x y r)
    (when (:drawing-flag display)
          (|_draw_ellipse| (:xdisplay display) x y r r)))

(de :fill-rectangle (display ge x y w h)
    (when (:drawing-flag display)
          (let ((pattern (current-pattern))
                (fg (current-foreground)))
            (when (eq 0 pattern) (current-foreground (current-background)))
            (|_fill_rectangle| (:xdisplay display) x y w h pattern)
            (when (eq 0 pattern) (current-foreground fg)))))

(de :fill-area (display ge n vx vy)
    (when (:drawing-flag display)
          (let ((pattern (current-pattern))
                (fg (current-foreground)))
            (when (eq 0 pattern) (current-foreground (current-background)))
            (|_fill_area| (:xdisplay display) n vx vy pattern)
            (when (eq 0 pattern) (current-foreground fg)))))

(de :fill-ellipse (display ge x y rx ry)
    (when (:drawing-flag display)
          (let ((pattern (current-pattern))
                (fg (current-foreground)))
            (when (eq 0 pattern) (current-foreground (current-background)))
            (|_fill_ellipse| (:xdisplay display) x y rx ry pattern)
            (when (eq 0 pattern) (current-foreground fg)))))

(de :fill-circle (display ge x y r)
    (:fill-ellipse display ge x y r r))

;;;;;;;;;;;;;;;;;;;;;;;;;;; La gestion du curseur ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de :cursor-max (display)
    (sub1 (vlength (#:display:x11:cursor-vector display))))

(de :make-cursor (display b1 b2 x y)
    (let* ((nbcursor (vlength (:cursor-vector display)))
           (bb1 (|_pixmap_to_bitmap|
                 (:xdisplay display)
                 (:xbitmap b1) (#:bitmap:w b1) (#:bitmap:h b1)))
           (bb2 (|_pixmap_to_bitmap|
                 (:xdisplay display)
                 (:xbitmap b2) (#:bitmap:w b2) (#:bitmap:h b2)))
           (fg (#:graph-env:foreground (#:display:graph-env display)))
           (bg (#:graph-env:background (#:display:graph-env display)))
           (xcursor (|_make_cursor|
                     (:xdisplay display) 
                     bb1 bb2
                     (#:color:red fg)
                     (#:color:green fg)
                     (#:color:blue fg)
                     (#:color:red bg)
                     (#:color:green bg)
                     (#:color:blue bg)
                     x y)))
      (:cursor-vector display
                      (bltvector (makevector (add1 nbcursor) 0)
                                 0 (:cursor-vector display) 0 nbcursor))
      (vset (:cursor-vector display) nbcursor xcursor)
      nbcursor))

(de :current-cursor (display cursor)
    (|_current_cursor| (:xdisplay display)
                       (vref (:cursor-vector display) cursor)))

(de :move-cursor (display x y)
    (|_move_cursor| (:xdisplay display) x y))

(de :draw-cursor (display ge x y st)
    (when (:drawing-flag display)
          (let ((color (if st
                           (#:graph-env:foreground ge)
                         (#:graph-env:background ge)))
                (xbase
                 (|_x_base_string|
                  (vref (:font-vector display) (#:graph-env:font ge))
                  " " 0 1))
                (ybase
                 (|_y_base_string|
                  (vref (:font-vector display) (#:graph-env:font ge))
                  " " 0 1))
                (height
                 (|_height_string|
                  (vref (:font-vector display) (#:graph-env:font ge))
                  " " 0 1)))
            (setq x (sub x xbase)
                  y (sub y ybase))
            (|_current_foreground| (:xdisplay display) (:xcolor color))
            (|_draw_line| (:xdisplay display) x y x (sub1 (add y height)))
            (|_current_foreground|
             (:xdisplay display) (:xcolor (#:graph-env:foreground ge))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Les couleurs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(unless (boundp ':rgb) (defvar :rgb #[() () ()]))

(de :make-color (display color r g b)
    (let ((c (|_make_color| (:xdisplay display) r g b :rgb)))
      (when (eq c -1)
            (error 'make-color errnomorecolors (list r g b)))
      (:do-color display color c :rgb)))

(de :make-mutable-color (display color r g b)
    (let ((c (|_make_mutable_color| (:xdisplay display) r g b)))
      (when (eq c -1)
            (error 'make-mutable-color errnomorecolors (list r g b)))
      (:do-color display color c :rgb)))

(de :make-named-color (display color s)
    (let ((c (|_make_named_color| (:xdisplay display) s :rgb)))
      (when (eq c -1)
            (error 'make-named-color errnomorecolors s))
      (:do-color display color c :rgb)))

(de :do-color (display color xcolor rgb)
    (or (any (lambda (c) (when (eq (:xcolor c) xcolor) c))
             (#:display:colors display))
        (progn
          (#:color:red color (vref rgb 0))
          (#:color:green color (vref rgb 1))
          (#:color:blue color (vref rgb 2))
          (:xcolor color xcolor)
          color)))

(de :kill-color (display c)
    (|_kill_color| (:xdisplay display) (:xcolor c)))

(de :current-foreground (display ge fore)
    (|_current_foreground| (:xdisplay display) (:xcolor fore)))

(de :current-background (display ge back)
    (|_current_background| (:xdisplay display) (:xcolor back)))

(de :red-component (display color red)
    (|_color_component| (:xdisplay display) (:xcolor color) 
                        red (#:color:green color) (#:color:blue color) 0))

(de :green-component (display color green)
    (|_color_component| (:xdisplay display) (:xcolor color) 
                        (#:color:red color) green (#:color:blue color) 1))

(de :blue-component (display color blue)
    (|_color_component| (:xdisplay display) (:xcolor color) 
                        (#:color:red color) (#:color:green color) blue 2))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;; Les Memoires de Points ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(de :create-bitmap (display bitmap)
    (#:bitmap:extend bitmap (#:x11:bitmap:make))
    (:xbitmap bitmap (|_create_bitmap| (:xdisplay display)
                                       (#:bitmap:w bitmap)(#:bitmap:h bitmap)))
    bitmap)

(de :create-window-bitmap (display window bitmap)
    (#:bitmap:extend bitmap (#:x11:bitmap:make))
    (:window-bitmap bitmap window)
    (:xbitmap bitmap (:xwindow (:top-window window)))
    bitmap)

(de :kill-bitmap (display bitmap)
    (unless (:window-bitmap bitmap)
            (when (:xbitmap bitmap)
                  (|_kill_bitmap| (:xdisplay display) (:xbitmap bitmap))))
    (:window-bitmap bitmap ())
    (:xbitmap bitmap ()))

(de :get-bit-line (display bitmap y bitvector)
    (let ((x 0))
      (when (:window-bitmap bitmap)
            (setq x (add x (:offset-x (:window-bitmap bitmap))))
            (setq y (add y (:offset-y (:window-bitmap bitmap)))))
      (|_get_bit_line| (:xdisplay display)
                       (:xbitmap bitmap) x y bitvector (#:bitmap:w bitmap))))

(de :set-bit-line (display bitmap y bitvector)
    (let ((x 0))
      (when (:window-bitmap bitmap)
            (setq x (add x (:offset-x (:window-bitmap bitmap))))
            (setq y (add y (:offset-y (:window-bitmap bitmap)))))
      (|_set_bit_line| (:xdisplay display)
                       (:xbitmap bitmap) x y bitvector (#:bitmap:w bitmap))))

(de :bmref (display bitmap x y)
    (when (:window-bitmap bitmap)
          (setq x (add x (:offset-x (:window-bitmap bitmap))))
          (setq y (add y (:offset-y (:window-bitmap bitmap)))))
    (|_bmref| (:xdisplay display) (:xbitmap bitmap) x y))

(de :bmset (display bitmap x y bit)
    (when (:window-bitmap bitmap)
          (setq x (add x (:offset-x (:window-bitmap bitmap))))
          (setq y (add y (:offset-y (:window-bitmap bitmap)))))
    (|_bmset| (:xdisplay display) (:xbitmap bitmap) x y bit)
    bit)

(de :bitblit (display b1 b2 x1 y1 x2 y2 w h)    
    (when (:window-bitmap b1)
          (setq x1 (add x1 (:offset-x (:window-bitmap b1))))
          (setq y1 (add y1 (:offset-y (:window-bitmap b1)))))
    (if (:window-bitmap b2)
        (progn (setq x2 (add x2 (:offset-x (:window-bitmap b2))))
               (setq y2 (add y2 (:offset-y (:window-bitmap b2)))))
      (when (le x2 0)
            (setq x1 (sub x1 x2))
            (setq w  (add w x2))
            (setq x2 0))
      (when (le y2 0)
            (setq y1 (sub y1 y2))
            (setq h  (add h y2))
            (setq y2 0))
      (when (gt (add x2 w) (#:bitmap:w b2))
            (setq w (sub (#:bitmap:w b2) x2)))
      (when (gt (add y2 h) (#:bitmap:h b2))
            (setq h (sub (#:bitmap:h b2) y2))))
    (|_bitblit| (:xdisplay display) (:xbitmap b1) (:xbitmap b2)
     x1 y1 x2 y2 w h
     (if (:window-bitmap b1)
         (:xgraph-env (:window-bitmap b1))
       (|_default_gc| (:xdisplay display)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;; Les Menus Lisp ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct #:image:rectangle:window:menu-window)

(de menuwindow (le to wi he ti)
    (let ((res (#:image:rectangle:window:menu-window:make)))
      (#:window:left res le)
      (#:window:top res to)
      (#:window:width res wi)
      (#:window:height res he)
      (#:window:title res ti)
      (#:window:hilited res 1)
      (#:window:visible res 1)
      res))

(defextern _set_menu_attributes (external external))

(de #:image:rectangle:window:menu-window:set-window-hints (window)
    (_set_menu_attributes (:xdisplay (#:window:display window))
                          (:xwindow window)))

(de :create-menu (display menu) 
    (#:menu:extend menu (#:x11:menu:make))
    menu) 

(de :kill-menu (display menu))

(de :activate-menu (display menu x y)
    (with ((current-display display))
          (:draw-menu menu x y)
          (:follow-mouse menu)
          (let (x y il item)
            (when (and (setq x (:invertedx menu))
                       (setq y (:invertedy menu))
                       (ge x 0)
                       (ge y 0)
                       (setq il (nth x (#:menu:itemlists menu)))
                       il
                       (setq item (nth y (#:menu:itemlist:items il)))
                       item
                       (neq 0 (#:menu:item:active item)))
                  (#:menu:item:value item)))))

(de :menu-insert-item (display menu choix index name active value))

(de :menu-insert-item-list (display menu choix name active))

(de :menu-delete-item-list (display menu choix))

(de :menu-delete-item (display menu choix index))

(de :menu-modify-item-list (display menu choix name active))

(de :menu-modify-item (display menu choix index name active value))

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

(de :itemlist:width (il)
    (let ((l (#:menu:itemlist:items il))
          (max 0)
          (width 0))
      (while (consp l)
        (setq width (width-string (#:menu:item:name (nextl l))))
        (when (gt width max) (setq max width)))
      max))

(de :height (menu)
    (mul (height-space)
         (let ((res 0) (l (#:menu:itemlists menu)))
           (while (consp l)
             (setq res 
                   (imax res (length (#:menu:itemlist:items (nextl l))))))
           res)))

(de :width (menu)
    (let ((res 0) (l (#:menu:itemlists menu)))
      (while (consp l)
        (setq res (add res (:itemlist:width (nextl l)))))
      res))

(de width-string (s)
    (width-substring s 0 (slen s)))


(de :draw-menu (menu x y)
    (setq x (max (add1 (div (:width menu) 2))
                 (min x (sub (sub (bitxmax) 3) (div (:width menu) 2)))))
    (setq y (max 1 (min y (sub (sub (bitymax) 3) (:height menu)))))
    (:invertedx menu ())
    (:invertedy menu ())
    (:menu-window menu
                  (menuwindow (sub x (div (:width menu) 2))
                               y
                               (:width menu)
                               (:height menu)
                               (#:menu:name menu)))
    (make-window (:menu-window menu)))

(de :redraw-menu (menu event)
    (let ((x (x-base-space))
          (y (y-base-space)))
      (with ((current-window (:menu-window menu)))
            (when event
                  (current-clip (#:event:x event)
                                (#:event:y event)
                                (#:event:w event)
                                (#:event:h event)))
            (clear-graph-env)
            (mapc (lambda (il)
                    (mapc (lambda (it)
                            (draw-string x y (#:menu:item:name it))
                            (setq y (add y (height-space))))
                          (#:menu:itemlist:items il))
                    (setq y (y-base-space))
                    (setq x (add x (:itemlist:width il))))
                  (#:menu:itemlists menu))
            (when (and (fixp (:invertedx menu)) (fixp (:invertedy menu)))
                  (:invert-item menu (:invertedx menu) (:invertedy menu)))
            (when event
                  (current-clip 0 0
                                (#:window:width (current-window))
                                (#:window:height (current-window))
                                )))))

(de :find-list (menu x)
    (:find-list1 (#:menu:itemlists menu) x 0))

(de :find-list1 (ils x res)
    (cond ((lt x 0) ())
	  ((null ils) ())
	  ((lt x (:itemlist:width (car ils)))
	   res)
	  (t
	   (:find-list1 (cdr ils)
			(sub x (:itemlist:width (car ils)))
			(add1 res)))))

(de :itemlist-x (menu x)
    (:itemlist-x1 x (#:menu:itemlists menu)))

(de :itemlist-x1 (x ils)
    (if (eq x 0) 0
      (add (:itemlist:width (car ils))
	   (:itemlist-x1 (sub1 x) (cdr ils)))))

(de :invert-item (menu x y)
    (let (il item)
      (when (and x y
		 (setq il (nth x (#:menu:itemlists menu)))
		 (neq 0 (#:menu:itemlist:active il))
		 (setq item (nth y (#:menu:itemlist:items il)))
		 (neq 0 (#:menu:item:active item)))
	    (let ((rx (:itemlist-x menu x))
		  (ry (mul y (height-space)))
		  (rw (:itemlist:width il))
		  (rh (height-space)))
              (with ((current-mode 6))
                    (fill-rectangle rx ry rw rh)
                    (:invertedx menu x)
                    (:invertedy menu y)
                    )))))

(de :next-position (menu event)
    (tag moved
         (while t
           (read-event event)
           (selectq (#:event:code event)
                    (repaint-window-event 
                     (when (eq (:menu-window menu) (#:event:window event))
                           (:redraw-menu menu event)))
                    (up-event (exit moved t))
                    (drag-event (exit moved ()))))))

(de :follow-mouse (menu)
    (grab-event (:menu-window menu))
    (bitmap-sync)
    (with ((current-window (:menu-window menu)))
          (let ((ix ()) (iy ()) nx ny px py
                (event '#.(#:event:make)))
            (until (:next-position menu event)
                   (setq ny (if (lt (#:event:y event) 0)
                                -1
                              (div (#:event:y event) (height-space)))
                         nx (:find-list menu (#:event:x event)))
                   (when (or (neq nx ix) (neq ny iy))
                         (:invert-item menu ix iy)
                         (setq ix nx iy ny)
                         (:invert-item menu ix iy)))
            (:invertedx menu ix)
            (:invertedy menu iy)))
    (ungrab-event)
    (kill-window (:menu-window menu))
    (bitmap-sync)
    (:menu-window menu ()))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;; Macros d'ecriture ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(dmd :xdisplay (dpy . val)
     (if val
         `(#:display:extend ,dpy ,. val)
       `(#:display:extend ,dpy)))

(dmd :xwindow (win . val)
     (if val
         `(#:x11:extend:xwindow (#:window:extend ,win) ,. val)
       `(#:x11:extend:xwindow (#:window:extend ,win))))

(dmd :xgraph-env (win . val)
     (if val
         `(#:x11:extend:xgraph-env (#:window:extend ,win) ,. val)
       `(#:x11:extend:xgraph-env (#:window:extend ,win))))

(dmd :view-rect (ge . val)
     (if val
         `(#:x11:extend:view-rect (#:graph-env:extend ,ge) ,. val)
       `(#:x11:extend:view-rect (#:graph-env:extend ,ge))))

(dmd :offset-x (win . val)
     (if val
         `(#:x11:extend:offset-x (#:window:extend ,win) ,. val)
       `(#:x11:extend:offset-x (#:window:extend ,win))))

(dmd :offset-y (win . val)
     (if val
         `(#:x11:extend:offset-y (#:window:extend ,win) ,. val)
       `(#:x11:extend:offset-y (#:window:extend ,win))))

(dmd :visible (win . val)
     (if val
         `(#:x11:extend:visible (#:window:extend ,win) ,. val)
       `(#:x11:extend:visible (#:window:extend ,win))))

(dmd :xcolor (c . val)
     (if val
         `(#:color:extend ,c ,. val)
       `(#:color:extend ,c)))

(dmd :xbitmap (bitmap . val)
     (if val
         `(#:x11:bitmap:xbitmap (#:bitmap:extend ,bitmap) ,. val)
       `(#:x11:bitmap:xbitmap (#:bitmap:extend ,bitmap))))

(dmd :window-bitmap (bitmap . val)
     (if val
         `(#:x11:bitmap:window (#:bitmap:extend ,bitmap) ,. val)
       `(#:x11:bitmap:window (#:bitmap:extend ,bitmap))))

(dmd :menu-window (menu . val)
     (if val
         `(#:x11:menu:window (#:menu:extend ,menu) ,. val)
       `(#:x11:menu:window (#:menu:extend ,menu))))

(dmd :invertedx (menu . val)
     (if val
         `(#:x11:menu:invertedx (#:menu:extend ,menu) ,. val)
       `(#:x11:menu:invertedx (#:menu:extend ,menu))))

(dmd :invertedy (menu . val)
     (if val
         `(#:x11:menu:invertedy (#:menu:extend ,menu) ,. val)
       `(#:x11:menu:invertedy (#:menu:extend ,menu))))

#|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;; les extensions du BV ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Le multi display ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(unless (getdef '|_wait_in_socket|)
        (defextern |_wait_in_socket| (fix) fix))

(de multiple-eventp ()
    (any (lambda (d)
           (with ((current-display d)) 
                 (when (send 'eventp d) d)))
         #:display:all-displays))

(de multiple-read-event event
    (ifn event
         (setq event #.(new 'event))
         (setq event (car event)))
    (let ((d ()) (tty ()))
      (until (or (setq d (multiple-eventp))
                 (setq tty (wait-in-socket))))
      (ifn tty
           (with ((current-display d))
                 (send 'read-event d event))
           (setq tty ())
           (setq event (read-mouse))
           (#:event:window event ())
           (#:event:code event 'ascii-event)
           (#:event:detail event (let ((#:sys-package:tty 'tty)) (tyi))))
      event))

(de multiple-peek-event event
    (ifn event
         (setq event #.(new 'event))
         (setq event (car event)))
    (let ((d))
      (until (setq d (multiple-eventp))
             (wait-in-socket))
      (with ((current-display d))
            (send 'peek-event d event)
            event)))

(de wait-in-socket ()
    (let ((mask (|_wait_in_socket| :file-descriptor-mask)))
      (or (eq 1 (load-byte mask 0 1))
          (mapc (lambda (d)
                  (:events-in-socket d 
                                     (eq 1 (load-byte mask
                                                      (:file-descriptor d)
                                                      1))))
                #:display:all-displays))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|#