; .EnTete "Le-Lisp (c) version 15.2" " " "Gestion du bitmap virtuel"
; .EnPied " " "%" " "
; .Chapitre 8 "Gestion du Bitmap"
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA. "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA "
; .Centre "*****************************************************************"
; .Centre "$Header: virbitmap.ll,v 4.10 89/01/11 17:54:11 nuyens Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'virbitmap))
(add-feature 'virbitmap)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; GLOBALES ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless (boundp 'errnotadisplay)
(defvar errnotadisplay
#- #:system:foreign-language "n'est pas un dispositif d'affichage"
#+ #:system:foreign-language "not a display"))
(unless (boundp 'errnotawindow)
(defvar errnotawindow
#- #:system:foreign-language "l'argument n'est pas une fene↑tre"
#+ #:system:foreign-language "not a window"))
(unless (boundp 'errnotawindowtype)
(defvar errnotawindowtype
#- #:system:foreign-language "l'argument n'est pas un type de fene↑tre"
#+ #:system:foreign-language "not a window type"))
(unless (boundp 'errnotabitmap)
(defvar errnotabitmap
#- #:system:foreign-language "l'argument n'est pas une ico↑ne"
#+ #:system:foreign-language "not a bitmap"))
(unless (boundp 'errnotamenu)
(defvar errnotamenu
#- #:system:foreign-language "l'argument n'est pas un menu"
#+ #:system:foreign-language "not a menu"))
(unless (boundp 'errnotacolor)
(defvar errnotacolor
#- #:system:foreign-language "l'argument n'est pas une couleur"
#+ #:system:foreign-language "not a color"))
(unless (boundp 'errnotamutable)
(defvar errnotamutable
#- #:system:foreign-language
"l'argument n'est pas une couleur modifiable"
#+ #:system:foreign-language "not a mutable color"))
(unless (boundp 'errbitmapinuse)
(defvar errbitmapinuse
#- #:system:foreign-language "pattern utilise' commme motif ou curseur"
#+ #:system:foreign-language "bitmap used as a pattern or a cursor"))
(unless (boundp 'errnotasaveddisplay)
(defvar errnotasaveddisplay
#- #:system:foreign-language "pas un display sauve par bitsave"
#+ #:system:foreign-language "not a bitsaved display"))
(unless (boundp '#:sys-package:bitmap) (defvar #:sys-package:bitmap))
(unless (boundp '#:bitmap:name) (defvar #:bitmap:name))
(unless (boundp '#:display:default-bitmap)
(defvar #:display:default-bitmap 'bvtty))
(unless (boundp '#:display:all-bitmaps) (defvar #:display:all-bitmaps))
(unless (boundp '#:display:all-displays) (defvar #:display:all-displays))
(unless (boundp '#:display:current-display) (defvar #:display:current-display))
(unless (boundp '#:window:prologuep) (defvar #:window:prologuep))
(unless (boundp '#:window:all-windows) (defvar #:window:all-windows))
(unless (boundp '#:window:current-window) (defvar #:window:current-window))
(unless (boundp '#:window:current-keyboard-focus-window)
(defvar #:window:current-keyboard-focus-window))
(unless (boundp '#:graph-env:current-graph-env)
(defvar #:graph-env:current-graph-env))
(unless (boundp '#:graph-env:main-graph-env)
(defvar #:graph-env:main-graph-env))
(unless (boundp '#:mode:set) (defvar #:mode:set 3))
(unless (boundp '#:mode:or) (defvar #:mode:or 7))
(unless (boundp '#:mode:xor) (defvar #:mode:xor 6))
(unless (boundp '#:mode:not) (defvar #:mode:not 12))
(unless (boundp '#:clip:x) (defvar #:clip:x 0))
(unless (boundp '#:clip:y) (defvar #:clip:y 0))
(unless (boundp '#:clip:w) (defvar #:clip:w 0))
(unless (boundp '#:clip:h) (defvar #:clip:h 0))
(unless (boundp '#:graph-env:vx) (defvar #:graph-env:vx #[0 0 0 0 0]))
(unless (boundp '#:graph-env:vy) (defvar #:graph-env:vy #[0 0 0 0 0]))
(unless (boundp '#:event:x) (defvar #:event:x))
(unless (boundp '#:event:y) (defvar #:event:y))
(unless (boundp '#:event:code) (defvar #:event:code))
(unless (boundp '#:event:move-event) (defvar #:event:move-event 256))
(unless (boundp '#:event:click-event)(defvar #:event:click-event 257))
(unless (boundp '#:mouse:event-mode) (defvar #:mouse:event-mode 0))
(unless (boundp '#:mouse:x) (defvar #:mouse:x))
(unless (boundp '#:mouse:y) (defvar #:mouse:y))
(unless (boundp '#:mouse:state) (defvar #:mouse:state))
(unless (boundp '#:check-window:x) (defvar #:check-window:x))
(unless (boundp '#:check-window:y) (defvar #:check-window:y))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Les fonctions de verification
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de #:display:check-display (fct display)
(ifn (memq display #:display:all-displays)
(error fct errnotadisplay display)
t))
(de #:window:check-window (fct display window)
(ifn display
(error fct errnotadisplay display)
(ifn (memq window (#:display:windows display))
(error fct errnotawindow window)
t)))
(de #:window:check-windows (fct win1 win2)
(ifn (eq (#:window:display win1) (#:window:display win2))
(error fct errnotadisplay (#:window:display win1))
t))
(de #:bitmap:check-bitmap (fct display bitmap)
(ifn display
(error fct errnotadisplay display)
t))
(de #:bitmap:check-bitmaps (fct b1 b2)
(ifn (eq (#:bitmap:display b1) (#:bitmap:display b2))
(error fct errnotadisplay (#:bitmap:display b1))
t))
(de #:menu:check-menu (fct display menu)
(ifn display
(error fct errnotadisplay display)
(ifn (memq menu (#:display:menus display))
(error fct errnotamenu menu)
t)))
(de #:color:check-color (fct display color)
(ifn display
(error fct errnotadisplay display)
(ifn (memq color (#:display:colors display))
(error fct errnotacolor color)
t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; CHARGEMENT ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de inibitmap bitmap
(let ((name (symbol () (cond ((consp bitmap) (car bitmap))
((getenv "BITMAP"))
(t #:display:default-bitmap)))))
(setq #:bitmap:name name)
(unless (cassq name #:display:all-bitmaps)
(let ((file (catenate #:system:virbitmap-directory
name
#:system:lelisp-extension)))
(if (probefile file)
(loadfile file t)
(error 'inibitmap errfile file)))
(setq #:display:all-bitmaps
(acons name #:sys-package:bitmap #:display:all-bitmaps)))
name))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; DISPLAY ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct display
name
package
device
xmax
ymax
eventmode
prologuep
keyboard-focus-window
window
graph-env
root-window
main-graph-env
background
foreground
windows
bitmaps
menus
colors ; liste des objets couleurs valides
font-names ; Alist (string . fix) donnant le nom des polices
pattern-bitmaps ; liste des bitmaps associe's aux motifs
cursor-bitmaps ; liste de (bitmap mask hotx hoty) associe's aux curseurs
extend)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de bitprologue args
(let ((name (when args (nextl args)))
(device (when args (nextl args))))
(when #:display:all-bitmaps
(unless name (setq name (caar #:display:all-bitmaps)))
(let* ((package (cassq name #:display:all-bitmaps))
(display (if (and package
(getfn1 package 'make)
(subtypep package 'display))
(new package)
(new 'display))))
(#:display:name display name)
(#:display:package display package)
(#:display:device display device)
(send 'bitprologue display)
(newl #:display:all-displays display)
(#:display:prologuep display t)
(unless (current-display) (current-display display))
display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (bitmap-save) (bitmap-save <displays>) (bitmap-save t)
; sauvegarde les fenetres, menus, icones, polices, motifs, couleurs et
; curseurs du display courant (sans argument), de tous les displays ouverts
; (si l'arg vaut T) de la liste de displays argument sinon)
; retourne en valeur la liste des displays sauves
; dans un etat tel que l'on peut la passer
; a la fonction bitrestore qui restore l'e'tat sauve.
; Utilise' typiquement aux alentour d'un save-core...
; Le display courant est retourne dans le car de la liste
; ce qui le rerendra courant au restore (sauf si un autre display
; non sauve est devenu courant pendant ce temps)
(de bitmap-save &nobind
(let ((displays (cond ((eq (arg) 0) (list (current-display)))
((eq (arg 0) t)
(ifn (current-display)
#:display:all-displays
(cons (current-display)
(delq (current-display)
#:display:all-displays))))
(t (arg 0)))))
(mapc ':save-a-display displays)
displays))
(de :save-a-display (display)
(let ((saved-windows (append (#:display:windows display) ()))
(saved-bitmaps
(mapcar (lambda (i)
(list i
(#:bitmap:w i) (#:bitmap:h i)
(#:bitmap:bits i)))
(#:display:bitmaps display)))
(saved-menus (append (#:display:menus display) ()))
(saved-colors (append (#:display:colors display) ()))
(saved-fonts (mapcar 'car (#:display:font-names display)))
(saved-patterns (append (#:display:pattern-bitmaps display) ()))
(saved-cursors (append (#:display:cursor-bitmaps display) ()))
(saved-current-window (#:display:window display))
(saved-focus-window (#:display:keyboard-focus-window display))
(saved-event-mode (#:display:eventmode display))
(saved-predefined (list 'saved-display
(#:display:root-window display)
(#:display:foreground display)
(#:display:background display))))
(setq saved-windows (delq (#:display:root-window display) saved-windows))
(mapc (lambda (window)
(unless (#:window:father window)
(check-window-position window)))
saved-windows)
(setq saved-colors (delq (#:display:foreground display) saved-colors))
(setq saved-colors (delq (#:display:background display) saved-colors))
(setq saved-fonts
(delq (font-name (standard-roman-font display)) saved-fonts))
(setq saved-fonts
(delq (font-name (standard-bold-font display)) saved-fonts))
(setq saved-fonts
(delq (font-name (large-roman-font display)) saved-fonts))
(setq saved-fonts
(delq (font-name (small-roman-font display)) saved-fonts))
(with ((current-display display))
(flush-event))
; on envoie le message bitsave
(when (and (#:display:check-display 'bitsave display)
(#:display:prologuep display))
(send 'bitmap-save display)
(:do-close display))
(#:display:eventmode display saved-event-mode)
(#:display:window display saved-current-window)
(#:display:keyboard-focus-window display saved-focus-window)
(#:display:windows display saved-windows)
(#:display:menus display saved-menus)
(#:display:bitmaps display saved-bitmaps)
(#:display:menus display saved-menus)
(#:display:colors display saved-colors)
(#:display:font-names display saved-fonts)
(#:display:pattern-bitmaps display saved-patterns)
(#:display:cursor-bitmaps display saved-cursors)
(#:display:extend display saved-predefined)
display))
; bitmap-restore rouvre une liste de display sauvegardes par la precedente
(de bitmap-restore (displays)
(mapc ':restore-a-display displays)
displays)
(de :restore-a-display (display)
(unless (and (consp (#:display:extend display))
(eq 'saved-display (car (#:display:extend display))))
(error 'bitrestore errnotasaveddisplay display))
(let ((saved-windows (#:display:windows display))
(saved-bitmaps (#:display:bitmaps display))
(saved-menus (#:display:menus display))
(saved-colors (#:display:colors display))
(saved-fonts (#:display:font-names display))
(saved-patterns (#:display:pattern-bitmaps display))
(saved-cursors (#:display:cursor-bitmaps display))
(saved-root-window (#:display:root-window display))
(saved-current-window (#:display:window display))
(saved-focus-window (#:display:keyboard-focus-window display))
(saved-event-mode (#:display:eventmode display display))
(saved-predefined (#:display:extend display)))
(#:display:windows display ())
(#:display:bitmaps display ())
(#:display:menus display ())
(#:display:colors display ())
(#:display:font-names display ())
(#:display:pattern-bitmaps display ())
(#:display:cursor-bitmaps display ())
(#:display:extend display ())
; on simule un (bitprologue), sur un display deja alloue
(send 'bitmap-restore display)
(newl #:display:all-displays display)
(#:display:prologuep display t)
(unless (current-display) (current-display display))
; on reconstruit tous les objets
(with ((current-display display))
(nextl saved-predefined) ; saved-display
(let ((newroot (root-window))
(oldroot (nextl saved-predefined)))
(:exchange-and-subst newroot oldroot (#:display:windows display))
(#:display:root-window display oldroot))
(let ((newfore (standard-foreground))
(oldfore (nextl saved-predefined)))
(:exchange-and-subst
newfore oldfore (#:display:colors display))
(#:display:foreground display oldfore)
(#:graph-env:foreground (#:display:main-graph-env display)
oldfore))
(let ((newback (standard-background))
(oldback (nextl saved-predefined)))
(:exchange-and-subst
newback oldback (#:display:colors display))
(#:display:background display oldback)
(#:graph-env:background (#:display:main-graph-env display)
oldback)))
(mapc (lambda ((i w h bits))
(:exchange-and-subst
(create-bitmap w h bits) i
(#:display:bitmaps display)))
saved-bitmaps)
(mapc (lambda (c)
(:exchange-and-subst
(if (#:color:name c)
(make-named-color (#:color:name c))
(if (#:color:mutable c)
(make-mutable-color (#:color:red c)
(#:color:green c)
(#:color:blue c))
(make-color (#:color:red c)
(#:color:green c)
(#:color:blue c))))
c
(#:display:colors display)))
saved-colors)
(mapc 'load-font saved-fonts)
(mapc 'make-pattern saved-patterns)
(mapc (lambda ((b1 b2 x y))
(make-cursor b1 b2 x y))
saved-cursors)
(:recreate-windows display saved-windows)
(:recreate-menus display saved-menus)
(current-window saved-current-window)
(current-keyboard-focus-window saved-focus-window)
(event-mode saved-event-mode)
display
)))
(de :recreate-windows (display windows)
; reconstruit les sous-fenetres de la liste windows
; si une fenetre a une pere qui n'a pas encore ete reconstruit
; on la colle en attente au bout de la liste
; ceci permet d'assurer que l'on reconstruit les peres avant les fils
(when windows
(if (and (#:window:father (car windows))
(not (windowp (#:window:father (car windows)))))
(:recreate-windows display (append1 (cdr windows) (car windows)))
(let* ((ge (#:window:graph-env (car windows)))
(bm (#:graph-env:bitmap ge))
(font (#:graph-env:font ge))
(line-style (#:graph-env:line-style ge))
(pattern (#:graph-env:pattern ge))
(mode (#:graph-env:mode ge))
(foreground (#:graph-env:foreground ge))
(background (#:graph-env:background ge))
(clip-x (#:graph-env:clip-x ge))
(clip-y (#:graph-env:clip-y ge))
(clip-w (#:graph-env:clip-w ge))
(clip-h (#:graph-env:clip-h ge))
(cursor (#:window:cursor (car windows))))
(make-window (car windows))
(with ((current-window (car windows)))
(current-font font)
(current-line-style line-style)
(current-pattern pattern)
(current-mode mode)
(current-foreground foreground)
(current-background background)
(current-clip clip-x clip-y clip-w clip-h)
(current-cursor cursor))
(when bm
(let ((newbm (window-bitmap (car windows))))
(exchvector newbm bm)
(#:graph-env:bitmap (#:window:graph-env (car windows))
bm))))
(:recreate-windows display (cdr windows)))))
(de :recreate-menus (display menus)
; reconstruit les menus de la liste menus
; on insere les itemlists et les items a l'envers
; ce qui permet de toujours utiliser la position 0
(mapc (lambda (menu)
(let ((new-menu (create-menu (#:menu:name menu))))
(mapc (lambda (il)
(menu-insert-item-list
new-menu
0
(#:menu:itemlist:name il)
(#:menu:itemlist:active il))
(mapc (lambda (i)
(menu-insert-item
new-menu
0
0
(#:menu:item:name i)
(#:menu:item:active i)
(#:menu:item:value i)))
(reverse (#:menu:itemlist:items il))))
(reverse (#:menu:itemlists menu)))
(:exchange-and-subst new-menu menu (#:display:menus display))))
menus))
(de :exchange-and-subst (new old newlist)
(exchvector new old)
(rplaca (memq new newlist) old))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de bitepilogue displays
(cond ((eq displays ()) (setq displays (list (current-display))))
((eq (car displays) t) (setq displays #:display:all-displays)))
(mapc
(lambda (d)
(when (and (#:display:check-display 'bitepilogue d)
(#:display:prologuep d))
(send 'bitepilogue d)
(:do-close d)))
displays))
(de :do-close (d)
(#:display:device d ())
(#:display:prologuep d ())
(#:display:eventmode d ())
(#:display:xmax d ())
(#:display:ymax d ())
(#:display:keyboard-focus-window d ())
(#:display:window d ())
(#:display:graph-env d ())
(#:display:root-window d ())
(#:display:main-graph-env d ())
(#:display:windows d ())
(#:display:bitmaps d ())
(#:display:menus d ())
(#:display:colors d ())
(#:display:font-names d ())
(#:display:pattern-bitmaps d ())
(#:display:cursor-bitmaps d ())
(#:display:extend d ())
(setq #:display:all-displays (delq d #:display:all-displays))
(when (eq d (current-display))
(if #:display:all-displays
(current-display (car #:display:all-displays))
(setq #:display:current-display ()))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de current-display &nobind
(if (or (eq 0 (arg)) (eq #:display:current-display (arg 0)))
#:display:current-display
(when (#:display:check-display 'current-display (arg 0))
(setq #:display:current-display (arg 0))
(send 'current-display #:display:current-display)
#:display:current-display)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de bitxmax &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'bitxmax display)
(#:display:xmax display))))
(de bitymax &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'bitymax display)
(#:display:ymax display))))
(de root-window &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'root-window display)
(#:display:root-window display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de bitmap-refresh &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'bitmap-refresh display)
(send 'bitmap-refresh display))))
(de bitmap-flush &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'bitmap-flush display)
(send 'bitmap-flush display))))
(de bitmap-sync &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'bitmap-sync display)
(send 'bitmap-sync display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de standard-roman-font &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'standard-roman-font display)
(send 'standard-roman-font display))))
(de standard-bold-font &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'standard-bold-font display)
(send 'standard-bold-font display))))
(de large-roman-font &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'large-roman-font display)
(send 'large-roman-font display))))
(de small-roman-font &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'small-roman-font display)
(send 'small-roman-font display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de standard-foreground-pattern &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'standard-foreground-pattern display)
(send 'standard-foreground-pattern display))))
(de standard-background-pattern &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'standard-background-pattern display)
(send 'standard-background-pattern display))))
(de standard-medium-gray-pattern &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'standard-medium-pattern display)
(send 'standard-medium-gray-pattern display))))
(de standard-light-gray-pattern &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'standard-light-gray-pattern display)
(send 'standard-light-gray-pattern display))))
(de standard-dark-gray-pattern &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'standard-dark-gray-pattern display)
(send 'standard-dark-gray-pattern display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de standard-lelisp-cursor &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'standard-lelisp-cursor display)
(send 'standard-lelisp-cursor display))))
(de standard-gc-cursor &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'standard-gc-cursor display)
(send 'standard-gc-cursor display))))
(de standard-busy-cursor &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'standard-busy-cursor display)
(send 'standard-busy-cursor display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; WINDOW ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct #:image:rectangle x y w h)
(defstruct #:image:rectangle:window
title
hilited
visible
graph-env
extend
father
properties
(cursor 0)
display
subwindows)
(setq #:sys-package:colon 'window)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de create-window (type le to wi he ti hi vi)
(setq type (compat-type type))
(let ((create (getfn1 type 'create)))
(unless create
(error 'create-window errnotawindowtype type))
(funcall create le to wi he ti hi vi)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de create-subwindow (type le to wi he ti hi vi fa)
(when (or (null fa)
(#:window:check-window 'create-subwindow
(if fa
(#:window:display fa)
(current-display))
fa))
(setq type (compat-type type))
(let ((create (getfn1 type 'create)))
(unless create
(error 'create-window errnotawindowtype type))
(funcall create le to wi he ti hi vi fa))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de make-window (window)
(unless (current-display) (bitprologue))
(let ((father (#:window:father window)))
(when father
(#:window:cursor window (#:window:cursor father))
(#:window:display window (#:window:display father))
(#:window:subwindows father
(cons window (#:window:subwindows father)))))
(unless (#:window:display window)
(#:window:display window (current-display)))
(unless (#:window:cursor window)
(#:window:cursor window 0))
(#:window:subwindows window ())
(with ((current-display (#:window:display window)))
(setq #:window:all-windows
(#:display:windows (#:window:display window)
(nconc1 (#:display:windows
(#:window:display window))
window)))
(send 'make-window window)
(when (#:window:graph-env window)
(unless (#:graph-env:display (#:window:graph-env window))
(#:graph-env:display (#:window:graph-env window)
(#:window:display window))))
window))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de current-window &nobind
(if (eq 0 (arg))
(#:display:window (current-display))
(let* ((window (arg 0))
(display (if window (#:window:display window) (current-display))))
(when (and display
(or (null window)
(#:window:check-window 'current-window display window)))
(with ((current-display display))
(when (#:display:window display)
(send 'uncurrent-window (#:display:window display)))
(setq #:window:current-window
(#:display:window display window))
(setq #:graph-env:current-graph-env
(#:display:graph-env display
(if window
(#:window:graph-env window)
(#:display:main-graph-env
display))))
(when (#:display:window display)
(send 'current-window (#:display:window display)))
window)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de modify-window (window le to wi he ti hi vi)
(when (and
(#:window:check-window 'modify-window (#:window:display window) window)
(neq (root-window) window)
(or le to wi he ti hi vi))
(when (or wi he)
(let* ((ge (#:window:graph-env window))
(b (#:graph-env:bitmap ge)))
(#:graph-env:clip-x ge 0)
(#:graph-env:clip-y ge 0)
(#:graph-env:clip-w ge (or wi (#:window:width window)))
(#:graph-env:clip-h ge (or he (#:window:height window)))
(when b
(#:bitmap:w b (#:graph-env:clip-w ge))
(#:bitmap:h b (#:graph-env:clip-h ge)))))
(with ((current-display (#:window:display window)))
(send 'modify-window window le to wi he ti hi vi))
window))
(de update-window (window le to wi he)
(when (and
(#:window:check-window 'update-window (#:window:display window) window)
(neq (root-window) window)
(or le to wi he))
(when (or wi he)
(let* ((ge (#:window:graph-env window))
(b (#:graph-env:bitmap ge)))
(#:graph-env:clip-x ge 0)
(#:graph-env:clip-y ge 0)
(#:graph-env:clip-w ge (or wi (#:window:width window)))
(#:graph-env:clip-h ge (or he (#:window:height window)))
(when b
(#:bitmap:w b (#:graph-env:clip-w ge))
(#:bitmap:h b (#:graph-env:clip-h ge)))))
(with ((current-display (#:window:display window)))
(send 'update-window window le to wi he))
window))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de kill-window (window)
(when (and
(#:window:check-window 'kill-window (#:window:display window) window)
(neq (root-window) window))
(mapc 'kill-window (#:window:subwindows window))
(when (#:window:father window)
(#:window:subwindows (#:window:father window)
(delq window (#:window:subwindows
(#:window:father window)))))
(with ((current-display (#:window:display window)))
(when (eq window (#:display:window (#:window:display window)))
(current-window ()))
(when (eq window (#:display:keyboard-focus-window
(#:window:display window)))
(current-keyboard-focus-window ()))
(setq #:window:all-windows
(#:display:windows (#:window:display window)
(delq window (#:display:windows
(#:window:display window)))))
(send 'kill-window window)
(#:window:display window ())
(#:window:extend window ())
(when (#:window:graph-env window)
(#:graph-env:display (#:window:graph-env window) ())
(#:graph-env:extend (#:window:graph-env window) ())
(#:graph-env:bitmap (#:window:graph-env window) ())))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de pop-window (window)
(when (and
(#:window:check-window 'pop-window (#:window:display window) window)
(neq (root-window) window))
(with ((current-display (#:window:display window)))
(setq #:window:all-windows
(#:display:windows (#:window:display window)
(nconc1
(delq window
(#:display:windows
(#:window:display window)))
window)))
(send 'pop-window window))))
(de move-behind-window (window1 window2)
(when (and (neq window1 window2)
(#:window:check-windows 'move-behind-window window1 window2)
(#:window:check-window 'move-behind-window
(#:window:display window1) window1)
(#:window:check-window 'move-behind-window
(#:window:display window2) window2)
(neq window1 (root-window))
(neq window2 (root-window)))
(with ((current-display (#:window:display window1)))
(#:display:windows (#:window:display window1)
(delq window1
(nreverse
(#:display:windows
(#:window:display window1)))))
(let ((all2 (memq window2 (#:display:windows
(#:window:display window2)))))
(rplacd all2 (cons window1 (cdr all2))))
(setq #:window:all-windows
(#:display:windows (#:window:display window2)
(nreverse (#:display:windows
(#:window:display
window2)))))
(send 'move-behind-window window1 window2))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de current-keyboard-focus-window &nobind
(if (eq 0 (arg))
(#:display:keyboard-focus-window (current-display))
(let* ((window (arg 0))
(display (if window (#:window:display window) (current-display))))
(when (and display
(or (null window)
(#:window:check-window 'current-keyboard-focus-window
display window)))
(with ((current-display display))
(when (#:display:keyboard-focus-window display)
(send 'uncurrent-keyboard-focus-window
(#:display:keyboard-focus-window display)))
(setq #:window:current-keyboard-focus-window
(#:display:keyboard-focus-window display window))
(when window
(send 'current-keyboard-focus-window window))
window)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de find-window (x y)
(unless (current-display) (bitprologue))
(when (current-display)
(send 'find-window (current-display) x y)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de map-window (window :x :y :lx :ly)
(when (and
(#:window:check-window 'map-window (#:window:display window) window)
(neq (root-window) window))
(send 'map-window window :x :y :lx :ly))
())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; UTILITAIRES ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de windowp (window)
(and (typep window '#:image:rectangle:window)
(#:window:extend window)
(#:window:display window)
window))
(de subwindowp (window1 window2)
(and (windowp window1)
(windowp window2)
(#:window:check-windows 'subwindowp window1 window2)
(subwindowp1 window1 window2)))
(de subwindowp1 (window1 window2)
(ifn window1 ()
(if (eq window1 window2)
window1
(subwindowp1 (#:window:father window1) window2))))
(de which-window ()
(unless (current-display) (bitprologue))
(read-mouse)
(find-window #:mouse:x #:mouse:y))
(de check-window-position (window)
(map-window window 0 0 '#:check-window:x '#:check-window:y)
(setq #:check-window:x (sub 0 #:check-window:x))
(setq #:check-window:y (sub 0 #:check-window:y))
(unless (and (eq (#:window:left window) #:check-window:x)
(eq (#:window:top window) #:check-window:y))
(update-window window
#:check-window:x #:check-window:y
() ())))
(dmd define-window-property-accessor (propertyname)
`(de ,(symbol '#:image:rectangle:window propertyname) &nobind
(if (eq (arg) 1)
(cassq ',propertyname
(#:image:rectangle:window:properties (arg 0)))
(#:image:rectangle:window:set-property
(arg 0)
',propertyname (arg 1)))))
(de #:image:rectangle:window:set-property (window name val)
(let ((pair (assq name (#:image:rectangle:window:properties window))))
(if pair
(rplacd pair val)
(#:image:rectangle:window:properties
window
(acons name val (#:image:rectangle:window:properties window))))))
(de compat-type (type)
(selectq type
(window '#:image:rectangle:window)
(#:window:tty '#:image:rectangle:window:tty)
(t type)))
(de #:image:rectangle:window:create (le to wi he ti hi vi . fa)
(let ((window (#:window:make)))
(#:window:left window le)
(#:window:top window to)
(#:window:width window wi)
(#:window:height window he)
(#:window:title window ti)
(#:window:hilited window hi)
(#:window:visible window vi)
(#:window:father window (when fa (car fa)))
(make-window window)))
(de #:image:rectangle:window:prin (window)
(princn #/#)
(princn #/<)
(prin (type-of window))
(princn #\sp)
(prin (#:window:title window))
(princn #/>))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; COMPATIBILITE ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(dmd #:window:make ()
'(#:image:rectangle:window:make))
(dmd #:window:left (w . r)
(if r `(vset ,w 0 ,(car r)) `(vref ,w 0)))
(dmd #:window:top (w . r)
(if r `(vset ,w 1 ,(car r)) `(vref ,w 1)))
(dmd #:window:width (w . r)
(if r `(vset ,w 2 ,(car r)) `(vref ,w 2)))
(dmd #:window:height (w . r)
(if r `(vset ,w 3 ,(car r)) `(vref ,w 3)))
(dmd #:window:title (w . r)
(if r `(vset ,w 4 ,(car r)) `(vref ,w 4)))
(dmd #:window:hilited (w . r)
(if r `(vset ,w 5 ,(car r)) `(vref ,w 5)))
(dmd #:window:visible (w . r)
(if r `(vset ,w 6 ,(car r)) `(vref ,w 6)))
(dmd #:window:graph-env (w . r)
(if r `(vset ,w 7 ,(car r)) `(vref ,w 7)))
(dmd #:window:extend (w . r)
(if r `(vset ,w 8 ,(car r)) `(vref ,w 8)))
(dmd #:window:father (w . r)
(if r `(vset ,w 9 ,(car r)) `(vref ,w 9)))
(dmd #:window:properties (w . r)
(if r `(vset ,w 10 ,(car r)) `(vref ,w 10)))
(dmd #:window:cursor (w . r)
(if r `(vset ,w 11 ,(car r)) `(vref ,w 11)))
(dmd #:window:display (w . r)
(if r `(vset ,w 12 ,(car r)) `(vref ,w 12)))
(dmd #:window:subwindows (w . r)
(if r `(vset ,w 13 ,(car r)) `(vref ,w 13)))
(de #:window:create l
(apply '#:image:rectangle:window:create l))
(de #:window:prin (window)
(#:image:rectangle:window:prin window))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; INDIRECTIONS ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de #:image:rectangle:window:make-window (window)
(if (#:window:father window)
(send 'create-subwindow (#:window:display window) window)
(send 'create-window (#:window:display window) window))
window)
(de #:image:rectangle:window:current-window (window)
(send 'current-window (#:window:display window) window))
(de #:image:rectangle:window:uncurrent-window (window)
(send 'uncurrent-window (#:window:display window) window))
(de #:image:rectangle:window:modify-window (window le to wi he ti hi vi)
(send 'modify-window (#:window:display window) window le to wi he ti hi vi))
(de #:image:rectangle:window:update-window (window le to wi he)
(send 'update-window (#:window:display window) window le to wi he))
(de #:image:rectangle:window:kill-window (window)
(send 'kill-window (#:window:display window) window))
(de #:image:rectangle:window:pop-window (window)
(send 'pop-window (#:window:display window) window))
(de #:image:rectangle:window:move-behind-window (window1 window2)
(send 'move-behind-window (#:window:display window1) window1 window2))
(de #:image:rectangle:window:current-keyboard-focus-window (window)
(send 'current-keyboard-focus-window (#:window:display window) window))
(de #:image:rectangle:window:uncurrent-keyboard-focus-window (window)
(send 'uncurrent-keyboard-focus-window (#:window:display window) window))
(de #:image:rectangle:window:map-window (window :x :y :lx :ly)
(send 'map-window (#:window:display window) window :x :y :lx :ly))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; COLOR ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq #:sys-package:colon 'color)
(defstruct color
name
red
green
blue
mutable
display
extend)
(de #:color:prin (c)
(princn #/#)
(princn #/<)
(prin (type-of c))
(princn #\sp)
(prin (#:color:name c))
(princn #\sp)
(prin (#:color:red c))
(princn #\sp)
(prin (#:color:green c))
(princn #\sp)
(prin (#:color:blue c))
(princn #\sp)
(prin (#:color:extend c))
(princn #/>))
(de standard-foreground ()
(unless (current-display) (bitprologue))
(#:display:foreground (current-display)))
(de standard-background ()
(unless (current-display) (bitprologue))
(#:display:background (current-display)))
(de make-color (red green blue)
(unless (current-display) (bitprologue))
(let ((color (#:color:make)))
(#:color:display color (current-display))
(#:color:red color red)
(#:color:green color green)
(#:color:blue color blue)
(setq color (send 'make-color (current-display) color red green blue))
(unless (memq color (#:display:colors (current-display)))
(#:display:colors
(current-display)
(nconc1 (#:display:colors (current-display)) color)))
color))
(de make-mutable-color (red green blue)
(unless (current-display) (bitprologue))
(let ((color (#:color:make)))
(#:color:display color (current-display))
(#:color:red color red)
(#:color:green color green)
(#:color:blue color blue)
(#:color:mutable color t)
(setq color
(send 'make-mutable-color (current-display) color red green blue))
(unless (memq color (#:display:colors (current-display)))
(#:display:colors
(current-display)
(nconc1 (#:display:colors (current-display)) color)))
color))
(de make-named-color (name)
(unless (current-display) (bitprologue))
(let ((color (#:color:make)))
(#:color:display color (current-display))
(#:color:name color name)
(setq color (send 'make-named-color (current-display) color name))
(unless (memq color (#:display:colors (current-display)))
(#:display:colors
(current-display)
(nconc1 (#:display:colors (current-display)) color)))
color))
(de kill-color (color)
(when (#:color:check-color 'kill-color (#:color:display color) color)
(send 'kill-color (#:color:display color) color)
(#:display:colors (#:color:display color)
(delq color
(#:display:colors (#:color:display color))))
(#:color:extend color ())
(#:color:display color ())))
(de red-component &nobind
(let ((arg (arg)) (color (arg 0)) (red (arg 1)))
(when (#:color:check-color 'red-component (#:color:display color) color)
(if (eq 1 arg)
(#:color:red color)
(unless (#:color:mutable color)
(error 'red-component errnotamutable color))
(send 'red-component (#:color:display color) color red)
(#:color:red color red)))))
(de blue-component &nobind
(let ((arg (arg)) (color (arg 0)) (blue (arg 1)))
(when (#:color:check-color 'blue-component (#:color:display color) color)
(if (eq 1 arg)
(#:color:blue color)
(unless (#:color:mutable color)
(error 'blue-component errnotamutable color))
(send 'blue-component (#:color:display color) color blue)
(#:color:blue color blue)))))
(de green-component &nobind
(let ((arg (arg)) (color (arg 0)) (green (arg 1)))
(when (#:color:check-color 'green-component (#:color:display color)
color)
(if (eq 1 arg)
(#:color:green color)
(unless (#:color:mutable color)
(error 'green-component errnotamutable color))
(send 'green-component (#:color:display color) color green)
(#:color:green color green)))))
(de all-colors &nobind
(unless (current-display) (bitprologue))
(let ((display (if (eq (arg) 0) (current-display) (arg 0))))
(when (#:display:check-display 'all-colors display)
(#:display:colors display))))
(de current-foreground &nobind
(let ((arg (arg)) (color (arg 0)))
(if (eq 0 arg)
(#:graph-env:foreground (#:display:graph-env (current-display)))
(when (#:color:check-color 'current-foreground
(#:color:display color) color)
(send 'current-foreground
(#:display:graph-env (#:color:display color)) color)
(#:graph-env:foreground
(#:display:graph-env (#:color:display color)) color)))))
(de current-background &nobind
(let ((arg (arg)) (color (arg 0)))
(if (eq 0 arg)
(#:graph-env:background (#:display:graph-env (current-display)))
(when (#:color:check-color 'current-background
(#:color:display color) color)
(send 'current-background
(#:display:graph-env (#:color:display color)) color)
(#:graph-env:background
(#:display:graph-env (#:color:display color)) color)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de #:graph-env:current-foreground (ge fore)
(send 'current-foreground (#:graph-env:display ge) ge fore))
(de #:graph-env:current-background (ge back)
(send 'current-background (#:graph-env:display ge) ge back))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; GRAPH-ENV ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct graph-env
(font 0)
(line-style 0)
(pattern 1)
(mode 3)
foreground
background
(clip-x 0)
(clip-y 0)
(clip-w 0)
(clip-h 0)
bitmap
display
extend)
(setq #:sys-package:colon 'graph-env)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de clear-graph-env ()
(when (current-display)
(send 'clear-graph-env (#:display:graph-env (current-display)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de current-clip &nobind
(when (current-display)
(let ((ge (#:display:graph-env (current-display)))
(arg (arg))
(x (arg 0))
(y (arg 1))
(w (arg 2))
(h (arg 3)))
(if (eq arg 0)
(progn (setq #:clip:x (#:graph-env:clip-x ge))
(setq #:clip:y (#:graph-env:clip-y ge))
(setq #:clip:w (#:graph-env:clip-w ge))
(setq #:clip:h (#:graph-env:clip-h ge)))
(#:graph-env:clip-x ge x)
(#:graph-env:clip-y ge y)
(#:graph-env:clip-w ge w)
(#:graph-env:clip-h ge h)
(send 'current-clip ge x y w h)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de draw-cursor (x y state)
(when (current-display)
(send 'draw-cursor (#:display:graph-env (current-display))
x y state)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de current-font &nobind
(when (current-display)
(let ((ge (#:display:graph-env (current-display)))
(arg (arg))
(font (arg 0)))
(if (eq arg 0)
(#:graph-env:font ge)
(ifn (and (fixp font) (ge font 0) (le font (font-max)))
(error 'current-font 'erroob font)
(send 'current-font ge font)
(#:graph-env:font ge font))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de font-max ()
(unless (current-display) (bitprologue))
(when (current-display)
(send 'font-max (#:display:graph-env (current-display)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de load-font (font)
(unless (current-display) (bitprologue))
(or (cassoc font (#:display:font-names (current-display)))
(let ((f (send 'load-font (#:display:graph-env (current-display))
font)))
(#:display:font-names
(current-display)
(nconc1 (#:display:font-names (current-display)) (cons font f)))
f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de font-name (font)
(unless (current-display) (bitprologue))
(let ((pair (rassoc font (#:display:font-names (current-display)))))
(ifn pair
(error 'font-name 'erroob font)
(car pair))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de draw-substring (x y s start length)
(when (current-display)
(send 'draw-substring (#:display:graph-env (current-display))
x y s start length)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de draw-cn (x y cn)
(when (current-display)
(send 'draw-cn (#:display:graph-env (current-display)) x y cn)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de width-substring (s start length)
(unless (current-display) (bitprologue))
(when (current-display)
(send 'width-substring (#:display:graph-env (current-display))
s start length)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de height-substring (s start length)
(unless (current-display) (bitprologue))
(when (current-display)
(send 'height-substring (#:display:graph-env (current-display))
s start length)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de x-base-substring (s start length)
(unless (current-display) (bitprologue))
(when (current-display)
(send 'x-base-substring (#:display:graph-env (current-display))
s start length)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de y-base-substring (s start length)
(unless (current-display) (bitprologue))
(when (current-display)
(send 'y-base-substring (#:display:graph-env (current-display))
s start length)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de x-inc-substring (s start length)
(unless (current-display) (bitprologue))
(when (current-display)
(send 'x-inc-substring (#:display:graph-env (current-display))
s start length)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de y-inc-substring (s start length)
(unless (current-display) (bitprologue))
(when (current-display)
(send 'y-inc-substring (#:display:graph-env (current-display))
s start length)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de current-line-style &nobind
(when (current-display)
(let ((ge (#:display:graph-env (current-display)))
(arg (arg))
(line-style (arg 0)))
(if (eq 0 arg)
(#:graph-env:line-style ge)
(ifn (and (fixp line-style) (ge line-style 0)
(le line-style (line-style-max)))
(error 'current-line-style 'erroob line-style)
(send 'current-line-style ge line-style)
(#:graph-env:line-style ge line-style))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de line-style-max ()
(unless (current-display) (bitprologue))
(when (current-display)
(send 'line-style-max (#:display:graph-env (current-display)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de current-pattern &nobind
(when (current-display)
(let ((ge (#:display:graph-env (current-display)))
(arg (arg))
(pattern (arg 0)))
(if (eq 0 arg)
(#:graph-env:pattern ge)
(ifn (and (fixp pattern) (ge pattern 0)
(le pattern (pattern-max)))
(error 'current-pattern 'erroob pattern)
(send 'current-pattern ge pattern)
(#:graph-env:pattern ge pattern))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de pattern-max ()
(unless (current-display) (bitprologue))
(when (current-display)
(send 'pattern-max (#:display:graph-env (current-display)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de make-pattern (bitmap)
(when (#:bitmap:check-bitmap 'make-pattern
(#:bitmap:display bitmap) bitmap)
(let ((display (#:bitmap:display bitmap)))
(with ((current-display display))
(let ((b (send 'make-pattern
(#:display:graph-env display)
bitmap)))
(#:display:pattern-bitmaps
display
(nconc1 (#:display:pattern-bitmaps display) bitmap))
b)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de current-mode &nobind
(when (current-display)
(let ((ge (#:display:graph-env (current-display)))
(arg (arg))
(mode (arg 0)))
(if (eq 0 arg)
(#:graph-env:mode ge)
(ifn (and (fixp mode) (ge mode 0) (le mode 16))
(error 'current-mode 'erroob mode)
(send 'current-mode ge mode)
(#:graph-env:mode ge mode))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de draw-point (x y)
(when (current-display)
(send 'draw-point (#:display:graph-env (current-display)) x y)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de draw-polymarker (n vx vy)
(when (current-display)
(send 'draw-polymarker (#:display:graph-env (current-display))
n vx vy)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de draw-line (x0 y0 x1 y1)
(when (current-display)
(send 'draw-line (#:display:graph-env (current-display))
x0 y0 x1 y1)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de draw-polyline (n vx vy)
(when (current-display)
(send 'draw-polyline (#:display:graph-env (current-display))
n vx vy)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de draw-rectangle (x y w h)
(when (current-display)
(send 'draw-rectangle (#:display:graph-env (current-display))
x y w h)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de fill-rectangle (x y w h)
(when (current-display)
(send 'fill-rectangle (#:display:graph-env (current-display))
x y w h)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de fill-area (n vx vy)
(when (current-display)
(send 'fill-area (#:display:graph-env (current-display)) n vx vy)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de draw-ellipse (x y rx ry)
(when (current-display)
(send 'draw-ellipse (#:display:graph-env (current-display))
x y rx ry)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de fill-ellipse (x y rx ry)
(when (current-display)
(send 'fill-ellipse (#:display:graph-env (current-display))
x y rx ry)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de draw-circle (x y r)
(when (current-display)
(send 'draw-circle (#:display:graph-env (current-display)) x y r)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de fill-circle (x y r)
(when (current-display)
(send 'fill-circle (#:display:graph-env (current-display)) x y r)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; INDIRECTIONS ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de #:graph-env:clear-graph-env (ge)
(send 'clear-graph-env (#:graph-env:display ge) ge))
(de #:graph-env:current-clip (ge x y w h)
(send 'current-clip (#:graph-env:display ge) ge x y w h))
(de #:graph-env:draw-cursor (ge x y st)
(send 'draw-cursor (#:graph-env:display ge) ge x y st))
(de #:graph-env:current-font (ge font)
(send 'current-font (#:graph-env:display ge) ge font))
(de #:graph-env:font-max (ge)
(send 'font-max (#:graph-env:display ge) ge))
(de #:graph-env:load-font (ge font)
(send 'load-font (#:graph-env:display ge) ge font))
(de #:graph-env:font-name (ge font)
(send 'font-name (#:graph-env:display ge) ge font))
(de #:graph-env:draw-cn (ge x y cn)
(send 'draw-cn (#:graph-env:display ge) ge x y cn))
(de #:graph-env:draw-substring (ge x y s st le)
(send 'draw-substring (#:graph-env:display ge) ge x y s st le))
(de #:graph-env:width-substring (ge s st le)
(send 'width-substring (#:graph-env:display ge) ge s st le))
(de #:graph-env:height-substring (ge s st le)
(send 'height-substring (#:graph-env:display ge) ge s st le))
(de #:graph-env:x-base-substring (ge s st le)
(send 'x-base-substring (#:graph-env:display ge) ge s st le))
(de #:graph-env:y-base-substring (ge s st le)
(send 'y-base-substring (#:graph-env:display ge) ge s st le))
(de #:graph-env:x-inc-substring (ge s st le)
(send 'x-inc-substring (#:graph-env:display ge) ge s st le))
(de #:graph-env:y-inc-substring (ge s st le)
(send 'y-inc-substring (#:graph-env:display ge) ge s st le))
(de #:graph-env:line-style-max (ge)
(send 'line-style-max (#:graph-env:display ge) ge))
(de #:graph-env:current-line-style (ge line-style)
(send 'current-line-style (#:graph-env:display ge) ge line-style))
(de #:graph-env:pattern-max (ge)
(send 'pattern-max (#:graph-env:display ge) ge))
(de #:graph-env:current-pattern (ge pattern)
(send 'current-pattern (#:graph-env:display ge) ge pattern))
(de #:graph-env:make-pattern (ge bitmap)
(send 'make-pattern (#:graph-env:display ge) ge bitmap))
(de #:graph-env:current-mode (ge mode)
(send 'current-mode (#:graph-env:display ge) ge mode))
(de #:graph-env:draw-point (ge x0 y0)
(send 'draw-point (#:graph-env:display ge) ge x0 y0))
(de #:graph-env:draw-polymarker (ge n vx vy)
(send 'draw-polymarker (#:graph-env:display ge) ge n vx vy))
(de #:graph-env:draw-line (ge x0 y0 x1 y1)
(send 'draw-line (#:graph-env:display ge) ge x0 y0 x1 y1))
(de #:graph-env:draw-polyline (ge n vx vy)
(send 'draw-polyline (#:graph-env:display ge) ge n vx vy))
(de #:graph-env:draw-rectangle (ge x y w h)
(send 'draw-rectangle (#:graph-env:display ge) ge x y w h))
(de #:graph-env:fill-area (ge n vx vy)
(send 'fill-area (#:graph-env:display ge) ge n vx vy))
(de #:graph-env:fill-rectangle (ge x y w h)
(send 'fill-rectangle (#:graph-env:display ge) ge x y w h))
(de #:graph-env:draw-ellipse (ge x y rx ry)
(send 'draw-ellipse (#:graph-env:display ge) ge x y rx ry))
(de #:graph-env:fill-ellipse (ge x y rx ry)
(send 'fill-ellipse (#:graph-env:display ge) ge x y rx ry))
(de #:graph-env:fill-circle (ge x y r)
(send 'fill-circle (#:graph-env:display ge) ge x y r))
(de #:graph-env:draw-circle (ge x y r)
(send 'draw-circle (#:graph-env:display ge) ge x y r))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; UTILITAIRES ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(dmd draw-string (x y s)
`(let ((#:graph-env:arg0 ,s))
(draw-substring ,x ,y #:graph-env:arg0 0 (slen #:graph-env:arg0))))
(de width-space ()
(width-substring " " 0 1))
(de height-space ()
(height-substring " " 0 1))
(de x-base-space ()
(x-base-substring " " 0 1))
(de y-base-space ()
(y-base-substring " " 0 1))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; CURSOR ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de cursor-max ()
(unless (current-display) (bitprologue))
(when (current-display)
(send 'cursor-max (current-display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de make-cursor (b1 b2 x y)
(when (and (#:bitmap:check-bitmaps 'make-cursor b1 b2)
(#:bitmap:check-bitmap 'make-cursor (#:bitmap:display b1) b1)
(#:bitmap:check-bitmap 'make-cursor (#:bitmap:display b2) b2))
(with ((current-display (#:bitmap:display b1)))
(let ((c (send 'make-cursor (#:bitmap:display b1) b1 b2 x y)))
(#:display:cursor-bitmaps
(current-display)
(nconc1 (#:display:cursor-bitmaps (current-display))
(list b1 b2 x y)))
c))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de current-cursor &nobind
(when (current-display)
(let ((window (#:display:window (current-display)))
(arg (arg))
(cursor (arg 0)))
(if (eq 0 arg)
(#:window:cursor window)
(ifn (and (fixp cursor) (ge cursor 0) (le cursor (cursor-max)))
(error 'current-cursor 'erroob cursor)
(send 'current-cursor (current-display) cursor)
(#:window:cursor window cursor))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de move-cursor (x y)
(unless (current-display) (bitprologue))
(when (current-display)
(send 'move-cursor (current-display) x y)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; EVENT ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq #:sys-package:colon 'mouse)
(defstruct event
code
window
detail
gx
gy
x
y
w
h)
(unless (boundp '#:mouse:event) (defvar #:mouse:event (#:event:make)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de event-mode &nobind
(when (current-display)
(if (eq (arg) 0)
(#:display:eventmode (current-display))
(send 'event-mode (current-display) (arg 0))
(setq #:mouse:event-mode
(#:display:eventmode (current-display) (arg 0))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de eventp ()
(when (current-display)
(send 'eventp (current-display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de read-event &nobind
(when (current-display)
(let ((event (if (eq (arg) 1) (arg 0) #:mouse:event)))
(send 'read-event (current-display) event)
(parse-event event)
event)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de peek-event &nobind
(when (current-display)
(let ((event (if (eq (arg) 1) (arg 0) #:mouse:event)))
(send 'peek-event (current-display) event)
(parse-event event)
event)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de local-read-event ()
(when (current-display)
(read-event #:mouse:event)
(map-window (current-window) #:event:x #:event:y
'#:event:x '#:event:y)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de flush-event ()
(when (current-display)
(send 'flush-event (current-display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de add-event &nobind
(when (current-display)
(cond ((eq (arg) 1)
(let ((event (arg 0)))
(send 'add-event (current-display) event)))
((eq (arg) 3)
(#:event:gx #:mouse:event (arg 0))
(#:event:gy #:mouse:event (arg 1))
(#:event:code #:mouse:event (arg 2))
(send 'add-event (current-display) #:mouse:event)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de grab-event (window)
(if window
(when (#:window:check-window 'grab-event (#:window:display window) window)
(send 'grab-event (#:window:display window) window)
window)
(when (current-display)
(send 'ungrab-event (current-display))
())))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de ungrab-event ()
(when (current-display)
(send 'ungrab-event (current-display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de itsoft-event ()
(when (current-display)
(send 'itsoft-event (current-display))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de read-mouse &nobind
(when (current-display)
(let ((event (if (eq (arg) 1) (arg 0) #:mouse:event)))
(send 'read-mouse (current-display) event)
(parse-mouse event)
event)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; UTILITAIRES ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de parse-event (event)
(setq #:event:x (#:event:gx event))
(setq #:event:y (#:event:gy event))
(setq #:event:code
(selectq (#:event:code event)
(ascii-event (#:event:detail event))
((move-event up-event) 257)
((down-event drag-event) 258)
(t 256))))
(de parse-mouse (event)
(setq #:mouse:x (#:event:gx event))
(setq #:mouse:y (#:event:gy event))
(setq #:mouse:state (#:event:detail event)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; MENU ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct menu
name
itemlists
display
extend)
(setq #:sys-package:colon 'menu)
(defstruct :itemlist
name
active
items)
(de :itemlist (name active items)
(let ((res (:itemlist:make)))
(:itemlist:name res name)
(:itemlist:active res active)
(:itemlist:items res items)
res))
(defstruct :item
name
active
value)
(de :item (name active value)
(let ((res (:item:make)))
(:item:name res name)
(:item:active res active)
(:item:value res value)
res))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de create-menu (title . values)
(unless (current-display) (bitprologue))
(let ((menu (#:menu:make))
(i -1))
(#:menu:display menu (current-display))
(#:menu:name menu title)
(setq menu (send 'create-menu (#:menu:display menu) menu))
(#:menu:display menu (current-display))
(#:menu:name menu title)
(#:display:menus (current-display)
(nconc1 (#:display:menus (current-display)) menu))
(menu-insert-item-list menu 0 title 1)
(while values
(menu-insert-item menu 0 (incr i)
(nextl values) 1 (nextl values)))
menu))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de kill-menu (menu)
(when (#:menu:check-menu 'kill-menu (#:menu:display menu) menu)
(send 'kill-menu (#:menu:display menu) menu)
(#:display:menus (#:menu:display menu)
(delq menu (#:display:menus (#:menu:display menu))))
(#:menu:extend menu ())
(#:menu:display menu ())))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de activate-menu (menu x y)
(when (#:menu:check-menu 'activate-menu (#:menu:display menu) menu)
(with ((current-display (#:menu:display menu)))
(send 'activate-menu (#:menu:display menu) menu x y))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de menu-insert-item-list (menu choix name active)
(when (#:menu:check-menu 'menu-insert-item-list (#:menu:display menu) menu)
(:itemlists menu
(insertnth choix (:itemlists menu)
(:itemlist name active ())))
(send 'menu-insert-item-list
(#:menu:display menu) menu choix name active)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de menu-insert-item (menu choix index name active value)
(when (#:menu:check-menu 'menu-insert-item (#:menu:display menu) menu)
(let ((il (nth choix (:itemlists menu))))
(when il
(:itemlist:items il
(insertnth index
(:itemlist:items il)
(:item name active value)))))
(send 'menu-insert-item (#:menu:display menu)
menu choix index name active value)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de menu-delete-item-list (menu choix)
(when (#:menu:check-menu 'menu-delete-item-list (#:menu:display menu) menu)
(:itemlists menu (deletenth choix (:itemlists menu))))
(send 'menu-delete-item-list (#:menu:display menu) menu choix)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de menu-delete-item (menu choix index)
(when (#:menu:check-menu 'menu-delete-item (#:menu:display menu) menu)
(let ((il (nth choix (:itemlists menu))))
(when il
(:itemlist:items il
(deletenth index (:itemlist:items il)))))
(send 'menu-delete-item (#:menu:display menu) menu choix index)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de menu-modify-item-list (menu choix name active)
(when (#:menu:check-menu 'menu-modify-item-list (#:menu:display menu) menu)
(let ((il (nth choix (:itemlists menu))))
(when il
(when name (:itemlist:name il (string name)))
(when active (:itemlist:name il active))))
(send 'menu-modify-item-list
(#:menu:display menu) menu choix name active)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de menu-modify-item (menu choix index name active value)
(when (#:menu:check-menu 'menu-modify-item (#:menu:display menu) menu)
(let ((il (nth choix (:itemlists menu))))
(when il
(let ((item (nth index il)))
(when name (:item:name item (string name)))
(when active (:item:name item active))
(when value (:item:name item value)))))
(send 'menu-modify-item
(#:menu:display menu) menu choix index name active value)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de deletenth (n l)
(cond ((atom l) l)
((eq n 0) (cdr l))
(t
(rplacd l (deletenth (sub1 n) (cdr l))))))
(de insertnth (n l i)
(cond ((atom l) (cons i l))
((eq n 0) (cons i l))
(t
(rplacd l (insertnth (sub1 n) (cdr l) i)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; BITMAP ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct bitmap
w
h
extend
display)
(setq #:sys-package:colon 'bitmap)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; CREATE-BITMAP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de create-bitmap (w h . bits)
(unless (current-display) (bitprologue))
(let ((bitmap (#:bitmap:make)))
(:w bitmap w)
(:h bitmap h)
(:display bitmap (current-display))
(setq bitmap (send 'create-bitmap (:display bitmap) bitmap))
(:w bitmap w)
(:h bitmap h)
(:display bitmap (current-display))
(#:display:bitmaps (current-display)
(nconc1 (#:display:bitmaps (current-display))
bitmap))
(:bits bitmap
(if bits
(car bits)
(makevector h (makestring (:round-to-byte w) 0))))
bitmap))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WINDOW-BITMAP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de window-bitmap (window)
(when (#:window:check-window 'window-bitmap
(#:window:display window) window)
(or (#:graph-env:bitmap (#:window:graph-env window))
(let ((bitmap (#:bitmap:make)))
(:display bitmap (#:window:display window))
(:w bitmap (#:window:width window))
(:h bitmap (#:window:height window))
(setq bitmap (send 'create-window-bitmap
(#:window:display window)
window
bitmap))
(:display bitmap (#:window:display window))
(:w bitmap (#:window:width window))
(:h bitmap (#:window:height window))
(#:graph-env:bitmap (#:window:graph-env window) bitmap)
bitmap))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; KILL-BITMAP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de kill-bitmap (bitmap)
(when (#:bitmap:check-bitmap 'kill-bitmap (#:bitmap:display bitmap) bitmap)
(send 'kill-bitmap (:display bitmap) bitmap)
(#:display:bitmaps (#:bitmap:display bitmap)
(delq bitmap (#:display:bitmaps
(#:bitmap:display bitmap))))
(#:bitmap:extend bitmap ())
(#:bitmap:display bitmap ())))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; BMREF et BMSET ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de bmref (bitmap x y)
(when (#:bitmap:check-bitmap 'bmref (#:bitmap:display bitmap) bitmap)
(send 'bmref (:display bitmap) bitmap x y)))
(de bmset (bitmap x y bit)
(when (#:bitmap:check-bitmap 'bmset (#:bitmap:display bitmap) bitmap)
(send 'bmset (:display bitmap) bitmap x y bit)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; BITBLIT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de bitblit (b1 b2 x1 y1 x2 y2 w h)
(when (and (#:bitmap:check-bitmaps 'bitblit b1 b2)
(#:bitmap:check-bitmap 'bitblit (#:bitmap:display b1) b1)
(#:bitmap:check-bitmap 'bitblit (#:bitmap:display b2) b2))
(send 'bitblit (:display b1) b1 b2 x1 y1 x2 y2 w h)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; UTILITAIRES ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(de #:sharp:* arg
(ncons (#:bitvector:read (car arg) ())))
(de #:sharp:|B| ()
(ncons (apply 'create-bitmap (read))))
(de #:bitmap:bits (bitmap . bits)
(if (null bits)
(let* ((hbitmap (#:bitmap:h bitmap))
(wbitmap (#:bitmap:w bitmap))
(strg-size (:round-to-byte wbitmap))
(strg-indmax (sub1 strg-size))
(last-bits (logand wbitmap 7))
(vect (makevector hbitmap ()))
(bitvector ())
(i 0))
(repeat hbitmap
(setq bitvector (makestring strg-size 0))
(vset vect i bitvector)
(typestring bitvector 'bitvector)
(send 'get-bit-line (:display bitmap) bitmap i bitvector)
(when (neq last-bits 0)
(sset bitvector
strg-indmax
(mask-field (sref bitvector strg-indmax)
(sub 8 last-bits)
8)))
(setq i (add1 i)))
vect)
(let ((vect (car bits))
(bitline)
(olbitline)
(n 0)
(i 0))
(repeat (vlength vect)
(setq bitline (vref vect n))
(setq n (add1 n))
(if (fixp bitline)
(repeat bitline
(send 'set-bit-line (:display bitmap)
bitmap i olbitline)
(setq i (add1 i)))
(send 'set-bit-line (:display bitmap) bitmap i bitline)
(setq i (add1 i))
(setq olbitline bitline))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; La variable #:SYSTEM:COMPRESSED-ICON permet d'imprimer les bitmaps et les
; bitvector sous forme compresse'e (en repe'rant les re'pe'titions de
; caracte`res et de lignes.
; et de lignes).
;
; Exemple:
;
; #B(40 4 #[#*0000000000
; #*0000000000
; #*0000000000
; #*a5a5a5f3f3])
;
; s'affichera en mode compresse' :
;
; #B(40 4 #[#5*00*4
; 2
; #5*a5*3f3f3])
;
;
; La #-macro *, permet de lire le mode normal ou le mode compresse'.
; Si l'argument nume'rique est fourni, il s'agit du mode compresse',
; s'il ne l'est pas c'est le mode in-extenso.
;
; De me↑me #:BITMAP:BITS de'code le mode compresse', on pourra donc
; e'crire, par exemple:
;
; #B(1000 1000 #[*#aa*fd 999])
;
; ou bien :
;
; #B(1000 1000 #[*125#aa*fd 999])
;
;
;
; Le format compresse' des BITVECTORs :
;
; Internal External
;
; Nible 0000 xxxx 0000 yyyy 0-9 A-F
; Predefined Byte 0001 xxxx G-V
; Small rep-factor 0010 xxxx a-p
; Large rep-factor 0011 0xxx 00yy yyyy q-x
;
; Terminal 0s 0011 1110 +
; User rep-factor 0011 1111 0000 xxxx 0000 yyyy * <h> <h>
; ExtraCode (not used) 0011 1xxx yzWXYZ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar :int->ext-encode-string
"0123456789ABCDEFGHIJKLMNOPQRSTUVabcdefghijklmnopqrstuvwxyzWXYZ+*")
(defvar :ext->int-encode-string
(let ((strg-buffer (makestring 128 #$FF)))
(for (strg-index 0 1 (1- (slength :int->ext-encode-string)))
(sset strg-buffer
(sref :int->ext-encode-string strg-index)
strg-index))
strg-buffer))
(defvar :predefined-bytes
(let ((strg-buffer (makestring 16 0)))
(sset strg-buffer 00 #$00)
(sset strg-buffer 01 #$FF)
(sset strg-buffer 02 #$01)
(sset strg-buffer 03 #$02)
(sset strg-buffer 04 #$04)
(sset strg-buffer 05 #$08)
(sset strg-buffer 06 #$10)
(sset strg-buffer 07 #$20)
(sset strg-buffer 08 #$40)
(sset strg-buffer 09 #$80)
(sset strg-buffer 10 #$44)
(sset strg-buffer 11 #$55)
(sset strg-buffer 12 #$AA)
(sset strg-buffer 13 #$11)
(sset strg-buffer 14 #$C0)
(sset strg-buffer 15 #$03)
strg-buffer))
(unless (boundp '#:system:compressed-icon)
(defvar #:system:compressed-icon))
(defmacro :round-to-byte (n)
`(logshift (add ,n 7) -3))
(defmacro :int->ext-encode (current-byte)
`(sref :int->ext-encode-string ,current-byte))
(de :ext->int-encode (current-byte)
(let ((code (sref :ext->int-encode-string (logand current-byte #$7F))))
(if (neq code #$FF)
code
(error '|#*| 'errsxt (list current-byte)))))
(de #:bitvector:read (strg-size strg-buffer)
(if (fixp strg-size)
(let ((previous-byte 0)
(current-byte)
(strg-index 0))
(setq strg-buffer (makestring strg-size 0))
(while (lt strg-index strg-size)
(setq current-byte (:ext->int-encode (readcn)))
(cond ((le current-byte #$F)
; le format "double nibble" complet.
(setq previous-byte
(logor (logshift current-byte 4)
(:ext->int-encode (readcn))))
(sset strg-buffer strg-index previous-byte)
(setq strg-index (add1 strg-index)))
((le current-byte #$1F)
; le format des caracte`res pre'de'finis
(setq previous-byte (sref :predefined-bytes
(logand current-byte #$F)))
(sset strg-buffer strg-index previous-byte)
(setq strg-index (add1 strg-index)))
((le current-byte #$3F)
; les re'pe'titeurs en tous genres.
(repeat (add1 (cond ((le current-byte #$2F)
; petits re'pe'titeurs
(logand current-byte #$F))
((lt current-byte #$3E)
; grands re'pe'titeurs
(logor (logshift (logand current-byte
#$F)
6)
(:ext->int-encode (readcn))))
((eq current-byte #$3E)
; re'pe'titeur terminal de 0 : "+"
(setq strg-index strg-size)
-1)
((eq current-byte #$3F)
; re'pe'titeur utilisateur : "*"
(logor (logshift (:ext->int-encode
(readcn))
4)
(:ext->int-encode (readcn))))))
(sset strg-buffer strg-index previous-byte)
(setq strg-index (add1 strg-index))))
(t (error "#*" 'errsxt current-byte)))))
(let ((current-list ()))
(untilexit complete
(newl current-list
(logor (logshift (:conv-to-hex (peekcn)) 4)
(progn (readcn)
(:conv-to-hex (readcn))))))
(setq strg-buffer (string (nreverse current-list)))))
(typestring strg-buffer 'bitvector)
strg-buffer)
(de :conv-to-hex (char)
(cond ((and (ge char #/0) (le char #/9))
(sub char #/0))
((and (ge char #/A) (le char #/F))
(sub char #.(- #/A 10)))
((and (ge char #/a) (le char #/f))
; a` cause que parfois ....
(sub char #.(- #/a 10)))
(t (exit complete))))
(de #:bitvector:prin (bitvector)
;; impression d'un vecteur de bits
(let ((strg-size (slen bitvector))
(strg-index 0)
(current-byte))
(let ((#:system:print-for-read ()))
(if #:system:compressed-icon
; ce code est faux en cas de coupure de ligne.
; mais en mode print-for-read+compressed-icon
; un terpri est re'alise' entre chaque ligne.
(prin "#" strg-size "*")
(prin "#*")))
(if #:system:compressed-icon
(let ((previous-byte -1)
(rep-factor 0))
(while (neq strg-index strg-size)
(setq current-byte (sref bitvector strg-index))
(if (eq current-byte previous-byte)
(setq rep-factor (add1 rep-factor))
(progn
(:prin-aux previous-byte rep-factor)
(setq rep-factor 0)
(setq previous-byte current-byte)))
(setq strg-index (add1 strg-index)))
(if (and (eq previous-byte 0)
(neq rep-factor 0))
(princn (:int->ext-encode 62))
(:prin-aux previous-byte rep-factor)))
(repeat strg-size
(setq current-byte (sref bitvector strg-index))
(princn (:int->ext-encode (logshift current-byte -4)))
(princn (:int->ext-encode (logand current-byte #$F)))
(setq strg-index (add1 strg-index))))))
(de :prin-aux (byte rep-factor)
;; imprime l'octet <byte> avec un facteur de re'pe'tition <rep-factor>
(when (neq byte -1)
; pour faciliter le de'marrage de la boucle
(let ((index-byte (chrpos byte :predefined-bytes)))
(if index-byte
; c'est un octet pre'de'fini
(princn (:int->ext-encode (add #$10 index-byte)))
(progn
; c'est un octet a` 2 nibles
(princn (:int->ext-encode (logshift byte -4)))
(princn (:int->ext-encode (logand byte #$F)))))))
(when (neq rep-factor 0)
; les facteurs de re'pe'titions partent a` 0
(setq rep-factor (sub1 rep-factor))
(if (lt rep-factor 16)
; facteur de re'pe'tition sur 1 octet
(princn (:int->ext-encode (add rep-factor #$20)))
(progn
; facteur de re'pe'tition sur 2 octets.
(princn (:int->ext-encode (add (logshift rep-factor -6) #$30)))
(princn (:int->ext-encode (logand rep-factor #$3F)))))))
(de #:bitmap:prin (bitmap)
(let ((hbitmap (:h bitmap))
(wbitmap (:w bitmap)))
(let ((#:system:print-for-read ()))
(prin "#B(" wbitmap " " hbitmap " #["))
(when #:system:print-for-read
(with ((rmargin (add1 (slen (outbuf)))))
(terpri)
(let* ((bbitmap (:round-to-byte wbitmap))
(bitvect1 (makestring bbitmap 0))
(bitvect2 (makestring bbitmap -1))
(indmax (sub1 bbitmap))
(last-bits (logand wbitmap 7))
(mask (logshift #$FF (sub 8 last-bits)))
(line-index 0)
(rep-factor 0))
(typestring bitvect1 'bitvector)
(typestring bitvect2 'bitvector)
(repeat hbitmap
(send 'get-bit-line (:display bitmap)
bitmap line-index bitvect1)
(setq line-index (add1 line-index))
(when (neq last-bits 0)
(sset bitvect1
indmax
(logand (sref bitvect1 indmax) mask)))
(if (and #:system:compressed-icon
(equal bitvect1 bitvect2)
(neq line-index 0))
(setq rep-factor (add1 rep-factor))
(progn
(when (neq rep-factor 0)
(print rep-factor))
(print bitvect1)
; l'e'change de HackMem
(setq bitvect2 (prog1 bitvect1
(setq bitvect1 bitvect2)))
(setq rep-factor 0))))
(when (neq rep-factor 0)
(print rep-factor)))))
(princn #/])
(princn #/) ))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;