; .Entete "virbitmap/bandetty.ll" "" "Fene↑trage sur terminal virtuel"
;
; .Section "Le multifene↑trage sur le terminal virtuel"
; .SSection "Description du bitmap attache' au terminal virtuel"
; $Header: bandetty.ll,v 4.2 88/04/07 18:48:05 devin Exp $
(defvar #:sys-package:bitmap '#:bitmap:bandetty)
(defvar #:sys-package:colon #:sys-package:bitmap)
(unless (boundp ':main-tty)
(defvar :xmax (sub1 (tyxmax)))
(defvar :ymax (tyymax))
; Le terminal sous-jacent
(defvar :main-tty 'tty))
(de :bitprologue ()
(tyflush)
(typrologue)
(setq :screen
(makestring (mul (add1 (bitxmax)) (add1 (bitymax))) #\sp))
(setq :oscreen (copy :screen))
(setq :blankscreen (copy :screen))
(setq :main-tty #:sys-package:tty)
(setq #:graph-env:main-graph-env (#:graph-env:make))
(setq #:graph-env:current-graph-env #:graph-env:main-graph-env)
(#:bitmap:bitprologue))
(de :bitepilogue ()
(tyflush)
(#:bitmap:bitepilogue)
(setq #:sys-package:tty :main-tty)
(tyepilogue)
(tyflush))
(de :bitmap-refresh ()
(:full-redisplay))
(de :bitmap-flush ())
(dmd with-main-tty body
`(progn (tyflush)
(let ((#:sys-package:tty :main-tty))
(protect (progn ,@body)
(tyflush)))))
; .Section "Implantation du fene↑trage virtuel sur terminal virtuel"
; .SSection "Structure des fene↑tres"
; Le champ extend contient la me'moire d'e'cran de la fene↑tre.
; La fonction de cre'ation cre'e cet e'cran et affiche la fene↑tre
(de :create-window (w)
(#:window:width w (add1 (bitxmax)))
(#:window:left w 0)
(#:window:extend
w
(:make-framed-screen (#:window:width w) (#:window:height w)
(#:window:title w) (#:window:hilited w)))
(#:window:graph-env w (#:graph-env:make))
(:redisplay t 0 0 0 0))
(de :create-subwindow (w)
(error ':create-subwindow "not yet implemented" ()))
(de :make-framed-screen (wi he ti hi)
(let ((s (makestring (mul (add wi 2) (add he 2)) #/.)))
(bltscreen s :blankscreen
(add wi 2) (add he 2)
(add1 (bitxmax)) (add1 (bitymax))
1 1
0 0
wi he)
(unless (= hi 0)
(fillstring s 0 #/= (add 2 wi)))
(bltstring s 1 ti 0 (min (slen ti) wi))
s))
; .SSection "Re'alisation des ope'rations primitives sur les fene↑tres"
(de #:image:rectangle:window:current-window (win))
(de #:image:rectangle:window:uncurrent-window (win)
(setq #:graph-env:current-graph-env #:graph-env:main-graph-env))
(de #:image:rectangle:window:modify-window (win le to wi he ti hi vi) ;
(when le
(setq le 0)
(#:window:left win le))
(when to
(#:window:top win to))
(when (or wi he)
(unless wi (setq wi (add1 (bitxmax))))
(unless he (setq he (#:window:height win)))
(let ((ns
(:make-framed-screen
wi he (#:window:title win) (#:window:hilited win))))
(bltscreen ns (#:window:extend win)
(add 2 wi) (add 2 he)
(add 2 (#:window:width win))
(add 2 (#:window:height win))
1 1
1 1
(min wi (#:window:width win))
(min he (#:window:height win)))
(#:window:extend win ns)
(#:window:width win wi)
(#:window:height win he)))
(when (or ti hi)
(when ti (#:window:title win ti))
(when hi (#:window:hilited win hi))
(fillstring (#:window:extend win)
0
(if (= (#:window:hilited win) 0) #/. #/=)
(add 2 (#:window:width win)))
(bltstring (#:window:extend win) 1
(#:window:title win) 0
(#:window:width win)))
(when vi
(#:window:visible win vi))
(:redisplay t 0 0 0 0)
win)
(de #:image:rectangle:window:kill-window (win)
(:redisplay t 0 0 0 0))
(de #:image:rectangle:window:pop-window (win)
(:redisplay t 0 0 0 0))
(de #:image:rectangle:window:move-behind-window (win1 win2)
(:redisplay t 0 0 0 0))
(de #:image:rectangle:window:current-keyboard-focus-window (win))
(de #:image:rectangle:window:uncurrent-keyboard-focus-window (win))
(de :find-window (x y)
(error ':find-window "not yet implemented" ()))
(unless (boundp ':lx)
(defvar :lx)
(defvar :ly))
(de #:image:rectangle:window:map-window (:win :x :y :lx :ly)
(set :lx (sub :x (#:window:left :win)))
(set :ly (sub :y (#:window:top :win))))
; Les souris (hummm le clavier en fait..)
(unless (boundp ':reread)
(defvar :reread ()))
(de :event-mode (mode))
(de :eventp ()
(or :reread
(let ((cn (with-main-tty (tys))))
(when cn
(setq :reread (ncons cn))))))
(de :read-event (event)
(make-ascii-event
event
(if :reread (nextl :reread) (with-main-tty (tyi)))))
(de :peek-event (event)
(make-ascii-event
event
(if :reread (car :reread)
(car (setq :reread (ncons (with-main-tty (tyi))))))))
(de :flush-event ()
(setq :reread ()))
(de :add-event (event))
(de :grab-event (window)
(error ':grab-event "not yet implemented" window))
(de :ungrab-event ()
(error ':ungrab-event "not yet implemented" ()))
(de :itsoft-event (event)
(error ':itsoft-event "not yet implemented" event))
(de :read-mouse (event)
(#:event:x event 0)
(#:event:y event 0)
(#:event:gx event 0)
(#:event:gy event 0)
(#:event:window event ())
(#:event:detail event 0))
(de make-ascii-event (event cn)
(#:event:detail event cn)
(#:event:code event 'ascii-event)
(#:event:window event (current-keyboard-focus-window))
(#:event:x event 0)
(#:event:y event 0)
(#:event:gx event 0)
(#:event:gy event 0)
event)
; .Section "La me'canique de gestion de l'e'cran"
; C'est ici qu'est re'alise' le de'coupage de l'e'cran en fene↑tres.
; La gestion de l'e'cran ne'cessite l'emploi de plusieurs chai↑nes de
; caracte`res de'crivant la me'moire d'e'cran.
(unless (boundp ':blankscreen)
; me'moire d'e'cran
(defvar :screen)
; la seconde me'moire pour le redisplayscreen
(defvar :oscreen)
; un blanc pour effacer vite fait
(defvar :blankscreen)
(defvar :flag t)
(defvar :delayed ()))
(dmd :normalizeq (var mini maxi)
`(progn
(setq ,var (min ,var ,maxi))
(setq ,var (max ,var ,mini))))
(de :delayed-redisplay l
(newl :delayed l))
(de :flush-delayed-redisplay (w le to wi he)
(ifn :delayed
(:do-redisplay w le to wi he)
(setq :delayed (nreverse :delayed))
(while :delayed
(apply ':do-redisplay (nextl :delayed)))
(unless (eq w t)
(:do-redisplay w le to wi he))))
(de :redisplay (w le to wi he)
(ifn :flag
(:delayed-redisplay w le to wi he)
(:flush-delayed-redisplay w le to wi he)))
(de :do-redisplay (w le to wi he)
(let ((:flag ()))
(tyflush)
(let (rmargin)
(with ((outchan t))
(setq rmargin (rmargin))
(rmargin (add1 (slen (outbuf)))))
(protect
(let ((#:sys-package:tty :main-tty))
(cond
((eq w t)
(bltscreen
:screen :blankscreen
(add1 (bitxmax)) (add1 (bitymax)))
(mapc ':redisplay1 #:window:all-windows)
(redisplayscreen :screen :oscreen
(add1 (bitxmax)) (add1 (bitymax))))
((<> (#:window:visible w) 0)
(mapc (lambda (w)
(:redisplay1-mini w le to
wi he))
(memq w #:window:all-windows))
(:normalizeq le 0 (add1 (bitxmax)))
(:normalizeq wi 0 (add1 (bitxmax)))
(:normalizeq to 0 (add1 (bitymax)))
(:normalizeq he 0 (add1 (bitymax)))
(redisplayscreen :screen :oscreen
(add1 (bitxmax)) (add1 (bitymax))
(add1 (bitxmax)) (add1 (bitymax))
le to
le to
wi he))
(t ()))
(tyflush))
(with ((outchan t))
(rmargin rmargin))))))
(de :redisplay1 (win)
(unless (= (#:window:visible win) 0)
(bltscreen :screen (#:window:extend win)
(add1 (bitxmax)) (add1 (bitymax))
(add 2 (#:window:width win)) (add 2 (#:window:height win))
(sub1 (#:window:left win)) (sub1 (#:window:top win))
0 0
(add 2 (#:window:width win)) (add 2 (#:window:height win)))))
(de :redisplay1-mini (win le to wi he)
(unless (= (#:window:visible win) 0)
(bltscreen :screen (#:window:extend win)
(add1 (bitxmax)) (add1 (bitymax))
(add 2 (#:window:width win)) (add 2 (#:window:height win))
le to
(add1 (sub le (#:window:left win)))
(add1 (sub to (#:window:top win)))
wi he)))
(de :full-redisplay ()
(let ((:flag ())) (tyflush))
(with-main-tty (tycls))
(bltscreen :oscreen :blankscreen (bitxmax) (bitymax))
(:redisplay t 0 0 0 0))
; Pour contourner le bug du redisplay non re'entrant
(de #:tty:window:redisplayscreen l
(let ((:flag ()))
(apply '#:tty:redisplayscreen l))
(:redisplay t 0 0 0 0))
(de #:tty:window:tycls ()
(for (i 0 1 (tyymax)) (tycursor 0 i) (tycleol))
(tycursor 0 0))
(de #:tty:window:tycleol ()
(let ((cw (eq (current-window) (car (last #:window:all-windows))))
(not-all-white
(tag not-all-white
(for (i (add (mul (add1 (#:image:rectangle:window:tty:cy (current-window)))
(add 2 (#:window:width (current-window))))
(add1 (#:image:rectangle:window:tty:cx (current-window)))) 1
(sub (mul (add 2
(#:image:rectangle:window:tty:cy (current-window)))
(add 2
(#:window:width (current-window))))
2))
(when (neq #\sp
(sref (#:window:extend (current-window)) i)
)
(exit not-all-white t)))
())))
(bltscreen
(#:window:extend (current-window))
:blankscreen
(add 2 (#:window:width (current-window)))
(add 2 (#:window:height (current-window)))
(add1 (bitxmax)) 1
(add1 (#:image:rectangle:window:tty:cx (current-window)))
(add1 (#:image:rectangle:window:tty:cy (current-window))) 0 0
(#:window:width (current-window)) 1)
(ifn cw
(:redisplay t 0 0 0 0)
(when not-all-white
(with-main-tty
(tycursor
(add (#:window:left (current-window))
(#:image:rectangle:window:tty:cx (current-window)))
(add (#:window:top (current-window))
(#:image:rectangle:window:tty:cy (current-window))))
(tycleol))
(bltscreen
:screen
:blankscreen
(add1 (bitxmax))
(add1 (bitymax)))
(mapc ':redisplay1
(memq (current-window) #:window:all-windows))
(bltscreen
:oscreen
:screen
(add1 (bitxmax))
(add1 (bitymax)))))))
(de #:tty:window:tynewline ()
(when #:tty:window:page-mode (tycleol))
(#:image:rectangle:window:tty:cx (current-window) 0)
(#:image:rectangle:window:tty:cy
(current-window)
(add (#:image:rectangle:window:tty:cy (current-window)) (height-space)))
(when (gt (sub (add (#:image:rectangle:window:tty:cy (current-window)) (height-space))
(y-base-space))
(#:window:height (current-window)))
(if #:tty:window:page-mode
(tycls)
(bltscreen
(#:window:extend (current-window))
(#:window:extend (current-window))
(add 2 (#:window:width (current-window)))
(add 2 (#:window:height (current-window)))
(add 2 (#:window:width (current-window)))
(add 2 (#:window:height (current-window)))
1 1
1 2
(#:window:width (current-window))
(sub1 (#:window:height (current-window))))
(bltscreen
(#:window:extend (current-window))
:blankscreen
(add 2 (#:window:width (current-window)))
(add 2 (#:window:height (current-window)))
(add1 (bitxmax)) 1
1 (#:window:height (current-window))
0 0
(#:window:width (current-window)) 1)
(if (eq (current-window) (car (last #:window:all-windows)))
(let ((#:sys-package:tty #:bitmap:bandetty:main-tty))
(tycursor
0
(#:window:top (current-window)))
(tydelln)
(tycursor
0
(sub1 (add (#:window:top (current-window))
(#:window:height (current-window)))))
(tyinsln)
(tyflush)
(bltscreen :screen :blankscreen (add1 (bitxmax)) (add1 (bitymax)))
(mapc ':redisplay1 (memq (current-window) #:window:all-windows))
(bltscreen :oscreen :screen (add1 (bitxmax)) (add1 (bitymax))))
(:redisplay t 0 0 0 0))
(#:image:rectangle:window:tty:cy
(current-window)
(sub1 (#:image:rectangle:window:tty:cy (current-window))))
)))
; Pour le tyi
(de #:tty:window:tybeep ()
(with-main-tty (tybeep)))
; les icones
(de :create-bitmap (a) a)
(de :create-window-bitmap (w a) a)
(de :get-bit-line (b i l))
(de :set-bit-line (b i l))
(de :kill-bitmap (b))
(de :bmset (b x y bi))
(de :bmref (b x y))
(de :bitblit (a b c d e f g h))
; .Section "Les environnements graphiques sur virtty"
; L'environnement graphique minimum comporte uniquement les primitives
; d'affichage de texte. Les mesures de texte sont en chasse fixe.
(defvar #:sys-package:colon 'graph-env)
; .SSection "Affichage de texte"
(de :clear-graph-env (ge)
(bltscreen (#:window:extend #:window:current-window)
#:bitmap:bandetty:blankscreen
(add 2 (#:window:width #:window:current-window))
(add 2 (#:window:height #:window:current-window))
(add1 (bitxmax)) (add1 (bitymax))
1 1
0 0
(#:window:width #:window:current-window)
(#:window:height #:window:current-window))
(#:bitmap:bandetty:redisplay t 0 0 0 0))
(de :draw-cursor (ge x y st)
(when (and #:bitmap:bandetty:flag
(neqn 0 (#:window:visible #:window:current-window))
(tyshowcursor))
(tyflush)
(let ((#:sys-package:tty #:bitmap:bandetty:main-tty))
(tyshowcursor st)
(when st
(tycursor
(add x (#:window:left (current-window)))
(add y (#:window:top (current-window)))))
(tyflush))))
(de :draw-substring (ge x y s st le)
(when #:window:current-window
(setq x (max x 0))
(setq y (max y 0))
(setq le (min (sub (#:window:width (current-window)) x) le))
(let ((xdeb (add (add1 x)
(mul
(add 2
(#:window:width #:window:current-window))
(add1 y)))))
(bltstring (#:window:extend #:window:current-window)
xdeb
s st le)
(when (eq (:font ge) 1)
(setq s (#:window:extend #:window:current-window))
(for (i xdeb
1
(sub1 (add xdeb (min le (slen s)))))
(sset s i (logor (sref s i) #$80)))))
(#:bitmap:bandetty:redisplay #:window:current-window
(add x (#:window:left #:window:current-window))
(add y (#:window:top #:window:current-window))
le 1)))
; .SSection "Mesure de texte"
(de :height-substring (ge s st le) 1)
(de :width-substring (ge s st le) (max 0 (min le (sub (slen s) st))))
(de :x-base-substring (ge s st le) 0)
(de :y-base-substring (ge s st le) 0)
(de :x-inc-substring (ge s st le) (:width-substring ge s st le))
(de :y-inc-substring (ge s st le) 0)
(de :current-font (ge font))
(de :font-max (ge) 1)
(de :load-font (ge font)
(error ':load-font 'erroob font))
; le vrai graphique
(de :current-clip (ge x y w h)
(error ':current-clip "not yet implemented" (list x y w h)))
(de :current-line-style (ge line-style))
(de :line-style-max (ge)
0)
(de :current-pattern (ge pattern))
(de :pattern-max (ge)
0)
(de :current-mode (ge mode))
(de :draw-polyline (ge n vx vy))
(de :draw-polymarker (ge n vx vy))
(de :fill-area (ge n vx vy))
(de :draw-ellipse (ge x y rx ry))
(de :fill-ellipse (ge x y rx ry))