#|
.Section "Incarnation des Me'moires de points sur X 10.4"

Une me'moire de points (type #:bitmap:x) peut etre de deux types:
    - une fene^tre X dans le serveur,
    - des points en me'moire dans le serveur (Pixmap).

Dans le premier cas le champ extend contient le nume'ro de la
fene^tre X-windows.

Dans le second cas le champ extend contient l'identificateur du Pixmap
utilise' par la fene^tre. Le champs stringbits contient une chai^ne de
caracte`re repre'sentant les bits du pixmap. Cette chai^ne n'est alloue'e
que si l'on utilise les fonctions set-bit-line et getGetX-bit-line.
On pourrait peut etre meme s'en passer.
|#

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

(defextern |_putpixmap| (fix fix fix fix fix fix fix external))
(defextern |_copyarea| (fix fix fix fix fix fix fix))
(defextern |_draw_line| (fix fix fix fix fix))
(defextern |_set_cur_mode| (fix fix))
(defextern |_XFreePixmap| (external))
(defextern |_XMakePixmap| (external fix fix) external)
(defextern |_XPixmapSave| (external fix fix fix fix) external)
(defextern |_XPixmapGetXY| (external fix fix fix fix external))
(defextern |_XPixmapBitsPutXY| (external fix fix fix fix string fix fix fix))
(defextern |_XStoreBitmap| (fix fix external) external)
(defextern |_XFreeBitmap| (external))
(defextern |_XPixmapPut| (external fix fix fix fix fix fix external fix fix))
(defextern |_XUnmapTransparent| (external))
(defextern |_rootwindow| () external)
(defextern |_Xwindow| (fix) external)

(defvar #:ex:regret)

(de |_big_malloc| (#:system:callext:arg0)
    (loc (callextern
             (precompile
                 '#.(getglobal '|_malloc|)
                 ()
                 ()
                 (eval (kwote (getglobal '|_malloc|)))) 0
             (vag #:system:callext:arg0) 0)))

(de |_mmalloc| (w h)
    (let ((#:ex:regret 0))
      (let ((low (ex* w h 0)))
        (|_big_malloc| (cons #:ex:regret low)))))
      
(defstruct :x stringbits)

(unless (boundp ':x:all-pixmaps)
	(defvar :x:all-pixmaps ()))


; nombre de plans de l'ecran
(unless (boundp ':planes)
        (defvar :planes 1))

; rang du plan correspondant au monochrome
(unless (boundp ':monoplane)
        (defvar :monoplane 0))

(unless (boundp ':bit-reverse-vector)
	(defvar :bit-reverse-vector)  ; dans x.ll
	)
#|
Macros locales pour reconnai^tre si un bitmap est une fene^tre ou un Pixmap
|#

(dmd window-bitmapp (bitmap)
     `(fixp (:extend ,bitmap)))

(dmd pixmap-bitmapp (bitmap)
     `(not (fixp (:extend ,bitmap))))

#|
Me'thodes du bitmap virtuel
|#

(de :create-bitmap (bitmap)
    (let ((nbitmap (#:bitmap:x:make)))
         (bltvector nbitmap 0 bitmap 0 (vlength bitmap))
         (when (eq 0 (#:bitmap:w nbitmap))
               (#:bitmap:w nbitmap 1))
         (when (eq 0 (#:bitmap:h nbitmap))
               (#:bitmap:h nbitmap 1))
         (:extend nbitmap
                  (|_XPixmapSave| (|_rootwindow|) 0 0
                                  (#:bitmap:w nbitmap)
                                  (#:bitmap:h nbitmap)))
	 (newl :x:all-pixmaps nbitmap)
         nbitmap))

(de :create-window-bitmap (window bitmap)
    (let ((nbitmap (#:bitmap:x:make)))
      (bltvector nbitmap 0 bitmap 0 (vlength bitmap))
      (:extend nbitmap (#:window:extend window))
      nbitmap))

#|
Destruction des bitmaps
|#

(de :kill-bitmap (bitmap)
    (if (window-bitmapp bitmap)
	() ; rien a faire
      (when (:extend bitmap)            ; au cas ou` de'ja tue'
            (|_XFreePixmap| (:extend bitmap))) ; destruction du pixmap
      (setq :x:all-pixmaps (delq bitmap :x:all-pixmaps))
      (:extend bitmap ())))             ; mise a () du pointeur

#|
Routine de blit ge'ne'ral

Il y a 4 cas selon que la source et la destination sont des
pixmap ou des fene^tres
|#

(de :bitblit (b1 b2 x1 y1 x2 y2 w h)
    (if (window-bitmapp b1)
	(if (window-bitmapp b2)
	    (:window-from-window b1 b2 x1 y1 x2 y2 w h)
	  (:window-from-pixmap b1 b2 x1 y1 x2 y2 w h))
      (if (window-bitmapp b2)
	  (:pixmap-from-window b1 b2 x1 y1 x2 y2 w h)
	(:pixmap-from-pixmap b1 b2 x1 y1 x2 y2 w h))))

(de :pixmap-from-window (b1 b2 x1 y1 x2 y2 w h)
    (ifn (and (eq 0 x1) (eq 0 y1)
	      (eq (:w b1) w) (eq (:h b1) h))
	 (error ':bitblit
		"cannot bitblt window to partial pixmap" (list b1 b2))
         (when (:extend b1)
               (|_XFreePixmap| (:extend b1)))
	 (:extend b1
		  (|_XPixmapSave|
		   (|_Xwindow| (:extend b2))
		   x2 y2 w h))))

(de :window-from-pixmap (b1 b2 x1 y1 x2 y2 w h)
    (when (null (:extend b2))
          (error 'window-from-pixmap "wrong pixmap" b2))
    (|_putpixmap| (:extend b1) x2 y2 x1 y1 w h (:extend b2)))

(de :pixmap-from-pixmap (b1 b2 x1 y1 x2 y2 w h)
    (error ':bitblit "cannot bitblt across pixmaps" (list b1 b2)))

(de :window-from-window (b1 b2 x1 y1 x2 y2 w h)
    (ifn (eq b1 b2)
	 (error ':bitblit
		"cannot bitblt across different windows" (list b1 b2))
	 (|_copyarea| (:extend b1) x2 y2 x1 y1 w h)))


#|
Transfert de bits entre le serveur et Le-Lisp
|#

(unless (boundp ':16bitvector)
        (defvar :16bitvector (makestring 0 0)))

(unless (boundp ':set16bitvector)
        (defvar :set16bitvector (makestring 0 0)))

(unless (boundp ':getbitwindow)
        (defvar :getbitwindow))

(unless (boundp ':getbitspace)
        (defvar :getbitspace))

(unless (boundp ':getbitcur)
        (defvar :getbitcur))

(defextern |_memcpy| (string external fix))

(de |_memcpy1| (#:system:callext:arg0
                #:system:callext:arg1 #:system:callext:arg2)
    (callextern
        (precompile '#.(getglobal '|_memcpy|)
                    () () (eval (kwote (getglobal '|_memcpy|)))) 1
        (vag #:system:callext:arg0) 0
        #:system:callext:arg1 3
        #:system:callext:arg2 1))

(unless (boundp ':setbitspace)
        (defvar :setbitspace))

(unless (boundp ':setbitcur)
        (defvar :setbitcur))

(unless (boundp ':getbitpixmap)
        (defvar :getbitpixmap))

(de :get-bit-line (bitmap i bitvector)
    (cond ((window-bitmapp bitmap)
           (let ((rw (mul 2 (quo (add (#:bitmap:w bitmap) 15) 16))))
             (when (eq i 0)
                   (when :getbitspace (|_free| :getbitspace))
                   (setq :getbitspace (|_mmalloc| (mul :planes rw)
                                                  (#:bitmap:h bitmap)))
                   (let ((#:ex:regret 0))
                     (setq :getbitcur
                           (addadr
                            :getbitspace
                            (xcons 
                             (ex* (mul rw :monoplane) (#:bitmap:h bitmap) 0)
                             #:ex:regret))))
                   (when (eq 0 :getbitspace)
                         (setq :getbitspace ())
                         (error 'get-bit-line "not enough space" bitmap))
                   (|_XPixmapGetXY| (|_Xwindow| (:extend bitmap))
                                    0 0
                                    (#:bitmap:w bitmap)
                                    (#:bitmap:h bitmap)
                                    :getbitspace)
                   (setq :16bitvector (makestring rw 0)))
             (|_memcpy| :16bitvector :getbitcur rw)
             (incradr :getbitcur rw)
             (:reverse-bit-vector :16bitvector)
             (bltstring bitvector 0 :16bitvector 0)
             (when (eq i (sub1 (#:bitmap:h bitmap)))
                   (|_free| :getbitspace)
                   (setq :getbitspace ()
                         :16bitvector ()))))
          (t
           (let* ((w (#:bitmap:w bitmap))
                  (h (#:bitmap:h bitmap)))
             (unless :getbitwindow
                     (setq :getbitwindow
                           (create-window 'window 0 0 w h "" 0 0)))
             (when (eq i 0)
                   (setq :getbitpixmap
                         (|_XPixmapSave|
                          (|_rootwindow|) 0 0 (add 2 w) (add 2 h)))
                   (modify-window :getbitwindow 0 0 w h ()()1)
                   (bitblit (window-bitmap :getbitwindow) bitmap 0 0 0 0 w h))
             (:get-bit-line (window-bitmap :getbitwindow) i bitvector)
             (when (eq i (sub1 h))
                   (|_XUnmapTransparent|
                    (|_Xwindow| (#:window:extend :getbitwindow)))
                   (|_XPixmapPut| (|_rootwindow|)
                                  0 0 0 0 (add 2 w) (add 2 h)
                                  :getbitpixmap
                                  3 1)
                   (|_XFreePixmap| :getbitpixmap)
                   (setq :getbitpixmap ())
                   (modify-window :getbitwindow ()() () () ()() 0)
                   (bitmap-flush))))))


(de :set-bit-line (bitmap i bitvector)
    (let* ((w (#:bitmap:w bitmap))
           (h (#:bitmap:h bitmap))
           (rw (mul 2 (quo (add w 15) 16))))
      (when (eq i 0)
            (setq :set16bitvector (makestring rw 0)))
      (bltstring :set16bitvector 0 bitvector 0)
      (if (window-bitmapp bitmap)
          (|_XPixmapBitsPutXY| (|_Xwindow| (:extend bitmap))
                               0 i w 1 :set16bitvector
                               0 12 1)
        (:reverse-bit-vector :set16bitvector)
        (when (eq i 0)
              (when :setbitspace (|_free| :setbitspace))
              (setq :setbitspace (|_mmalloc| rw h))
              (setq :setbitcur (cons (car :setbitspace)(cdr:setbitspace)))
              (when (eq 0 :setbitspace)
                    (setq :setbitspace ())
                    (error 'set-bit-line "not enough space" bitmap)))
        (|_memcpy1|  :setbitcur :set16bitvector rw)
        (incradr :setbitcur rw)
        (when (eq i (sub1 h))
              (let ((Xbitmap (|_XStoreBitmap| w h :setbitspace)))
                (when (:extend bitmap)
                      (|_XFreePixmap| (:extend bitmap))
                      (:extend bitmap ()))
                (:extend bitmap (|_XMakePixmap| Xbitmap 1 0))
                (|_XFreeBitmap| Xbitmap)
                (|_free| :setbitspace)
                (setq :setbitspace ()))))
      (when (eq i (sub1 h))
            (setq :set16bitvector ()))))


#|
Ecriture de points
|#
(unless (boundp ':bmrefspace)
        (defvar :bmrefspace))

(defextern |_llreversevideo| () fix)


; L'appel de XPixmapGetXY avec 1 1 pour largeur hauteur plante le serveur
; sur les ecrans couleurs. Par contre, ca marche tres bien avec 2 2 !
; Le patch ci-dessous ne marche pas pour des bitmaps de moins de 2 pixels
; en hauteur ou en largeur.

(de :bmref (bm i j) 
    (unless :bmrefspace
            (setq :bmrefspace (|_malloc| (mul :planes 8))))
    (cond ((window-bitmapp bm)
           (|_XPixmapGetXY| (|_Xwindow| (:extend bm))
                            (min (sub (#:bitmap:w bm) 2) i)
                            (min (sub (#:bitmap:h bm) 2) j)
                            2 2
                            :bmrefspace)
           (let ((dx (if (eqn i (sub1 (#:bitmap:w bm))) -1 0))
                 (dy (if (eqn j (sub1 (#:bitmap:h bm))) 2 0)))
             (logand 1
                     (logshift 
                      (if (eq (|_llreversevideo|) 0)
                          (lognot (|_shortref| :bmrefspace dy))
                        (|_shortref| :bmrefspace dy))
                      dx))))
          (t (error 'bmref  "cannot bmref pixmap" bm))))

(de :bmset (bm i j b)
    (cond ((window-bitmapp bm)
           (|_set_cur_mode| (#:bitmap:extend bm) (if (eqn b 0) 12 3))
           (|_draw_line| (#:bitmap:extend bm) i j i j)
           (|_set_cur_mode| (#:bitmap:extend bm) 3))
          (t (error 'bmset  "cannot bmset pixmap" bm))))

#|
Retournement des vecteurs de bits
|#


(de :reverse-bit-vector (bitvector)
    (let (rev1 rev2)
      (for (i 0 2 (sub (slen bitvector) 2))
	   (setq rev1 (:bit-reverse (sref bitvector i)))
	   (setq rev2 (:bit-reverse (sref bitvector (add1 i))))
           (if (memq (system) '(vaxunix vaxvms))
               (progn
                 (sset bitvector i rev1)               
                 (sset bitvector (add1 i) rev2))
             (sset bitvector i rev2)
             (sset bitvector (add1 i) rev1)))))

(de :bit-reverse (n)
    (logor
        (logshift (vref :bit-reverse-vector (logand n #$F)) 4)
        (vref :bit-reverse-vector (logshift n -4))))