#|
.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))))