Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
eclipse
eclipse
Commits
ff6838b0
Commit
ff6838b0
authored
Jan 16, 2005
by
Iban Hatchondo
Browse files
Documentation added.
(defun maximize-window) becomes (defgeneric maximize)
parent
f1b9bc05
Changes
6
Hide whitespace changes
Inline
Side-by-side
global.lisp
View file @
ff6838b0
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: global.lisp,v 1.2
6
200
4/11/30 23:48:10
ihatchondo Exp $
;;; $Id: global.lisp,v 1.2
7
200
5/01/05 23:13:07
ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2001, 2002 Iban HATCHONDO
...
...
@@ -90,32 +90,34 @@
(
defparameter
*focus-type*
:none
"values are: :none :on-click"
)
(
defparameter
*maximize-modifer*
:SHIFT-LEFT
"If modifier is down when pressing on a maximize button then it will be
equivalent to maximizing the window with (not *maximize-fill*)."
)
equivalent to maximizing the window with (not *maximize-fill*)."
)
(
defparameter
*maximize-fill*
nil
"Indicate if the action of maximizing window should making it filling whether
the largest area around (excluding overlapped windows) or screen area."
)
"Indicate
s
if the action of maximizing window should making it filling whether
the largest area around (excluding overlapped windows) or screen area."
)
(
defparameter
*icon-hints*
t
"
i
f you don't want eclipse to display miniature window for icons say nil"
)
"
I
f you don't want eclipse to display miniature window for icons say nil"
)
(
defparameter
*icon-box*
'#(
-75
5
-5
-5
)
"
t
op left and bottom right corner coordinates of the icon box area"
)
"
T
op left and bottom right corner coordinates of the icon box area"
)
(
defparameter
*icon-box-sep*
2
)
(
defparameter
*icon-box-fill*
:top-right
"
i
con box fill strategy, one of :{top,bottom}-{left,right}"
)
"
I
con box fill strategy, one of :{top,bottom}-{left,right}"
)
(
defparameter
*icon-box-sort-function*
nil
"Function determining icon order within the box.
NIL corresponds to the default which is to sort on order of creation
\(aka `icon-sort-creation-order'\)."
)
NIL corresponds to the default which is to sort on order of creation
\(aka `icon-sort-creation-order'\)."
)
(
defsetf
font-name
()
(
name
)
"Sets the title bar font to the font named by `name'.
The following pattern characters can be used for wildcard matching:
#\* Matches any sequence of zero or more characters.
#\? Matches any single character."
The following pattern characters can be used for wildcard matching:
#\* Matches any sequence of zero or more characters.
#\? Matches any single character."
`
(
if
(
xlib:list-font-names
*display*
,
name
)
(
setf
(
xlib:gcontext-font
*gcontext*
)
(
xlib:open-font
*display*
,
name
))
(
format
*stderr*
"~a is not a valid font name or pattern~%"
,
name
)))
(
defsetf
decoration-theme
(
&key
free-old-theme-p
)
(
name
)
"Sets the theme that must be used for window decoration. This theme will
be used for all existing applications as well as futur one."
`
(
with-slots
(
decoration-theme
)
*root*
(
let
((
theme
(
load-theme
*root-window*
,
name
)))
(
when
decoration-theme
...
...
@@ -129,6 +131,7 @@
(
setf
decoration-theme
theme
))))
(
defsetf
maximize-modifier
()
(
modifier-key
)
"Sets the modifier to use to activate window maximization second behavior."
`
(
if
(
member
,
modifier-key
(
kb:modifiers
))
(
setf
*maximize-modifer*
,
modifier-key
)
(
error
"Invalid modifier key: ~a is not a (member ~a)~%"
...
...
@@ -136,7 +139,7 @@
(
defmacro
deftypedparameter
(
type
symbol
value
&optional
documentation
)
"Defines a parameter with the same syntax and behavior as defparameter
except that its type must be given first."
except that its type must be given first."
`
(
progn
(
defparameter
,
symbol
,
value
,
documentation
)
(
declaim
(
type
,
type
,
symbol
))))
...
...
@@ -155,6 +158,9 @@
;;;; Input protocol.
(
defgeneric
event-process
(
event
widget
)
(
:documentation
"Input protocol method. This method will be invoke inside
an infinite loop that represent the heart of the window manager. Override
this method to handle as many widget/event combination that is needed."
)
(
:method
(
event
widget
)
nil
))
;;;; System dependent functions.
...
...
input.lisp
View file @
ff6838b0
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: input.lisp,v 1.
39
200
4/11/30 23:48:10
ihatchondo Exp $
;;; $Id: input.lisp,v 1.
40
200
5/01/05 23:13:07
ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
...
...
@@ -307,9 +307,9 @@
(
setf
(
window-desktop-num
window
)
+any-desktop+
)
(
xlib:map-window
window
))))
;; win_state_maximized_vert
(
when
(
logbitp
2
to-change
)
(
maximize
-window
application
2
))
(
when
(
logbitp
2
to-change
)
(
maximize
application
2
))
;; win_state_maximized_horiz
(
when
(
logbitp
3
to-change
)
(
maximize
-window
application
3
))
(
when
(
logbitp
3
to-change
)
(
maximize
application
3
))
;; win_state_shaded
(
when
(
and
(
logbitp
5
to-change
)
master
)
(
shade
master
))))
(
:_net_wm_state
...
...
@@ -332,9 +332,9 @@
(
setf
(
fullscreen-mode
application
)
(
if
(
=
mode
0
)
:off
:on
))))
(
when
(
or-eql
:_net_wm_state_maximized_vert
p1
p2
)
(
maximize
-window
application
2
))
(
maximize
application
2
))
(
when
(
or-eql
:_net_wm_state_maximized_horz
p1
p2
)
(
maximize
-window
application
3
))
(
maximize
application
3
))
(
when
(
and
master
(
or-eql
:_net_wm_state_shaded
p1
p2
))
(
shade
master
))
(
when
(
or-eql
:_net_wm_state_sticky
p1
p2
)
...
...
@@ -404,8 +404,7 @@
(
mod
(
kb:modifier->modifier-mask
*display*
*maximize-modifer*
)))
(
unless
(
eq
0
(
logand
mod
state
))
(
setf
fill-p
(
not
*maximize-fill*
)))
(
maximize-window
(
get-child
master
:application
)
(
event-code
event
)
:fill-p
fill-p
)))
(
maximize
master
(
event-code
event
)
:fill-p
fill-p
)))
(
when
(
eq
*focus-type*
:on-click
)
(
focus-widget
max-b
0
))))
;; Initialize the resize process.
...
...
package.lisp
View file @
ff6838b0
;;; -*- Mode: Lisp; Package: User -*-
;;; $Id: package.lisp,v 1.1
7
2004/0
2/17 22:30
:5
0
ihatchondo Exp $
;;; $Id: package.lisp,v 1.1
8
2004/0
3/01 14:53
:5
7
ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
...
...
@@ -167,7 +167,6 @@
#:make-title-bar
;function
#:make-viewport-property
;function
#:maximize-modifier
;setf function
#:maximize-window
;function
#:motif-wm-decoration
;function
#:mouse-stroke-for-move-and-resize
;function
#:mouse-stroke-p
;function
...
...
@@ -264,6 +263,7 @@
#:iconify
;generic function
#:initialize-move
;generic function
#:keystroke-keysyms
;generic function
#:maximize
;generic function
#:menu-3-process
;generic function
#:menu-leaf-callback
;generic function
#:menu-root-application-window
;generic function
...
...
virtual-screen.lisp
View file @
ff6838b0
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: virtual-screen.lisp,v 1.2
1
2004/
03/10 17:13:14
ihatchondo Exp $
;;; $Id: virtual-screen.lisp,v 1.2
2
2004/
12/16 21:36:47
ihatchondo Exp $
;;;
;;;Copyright (C) 2002 Iban HATCHONDO
;;;
Copyright (C) 2002 Iban HATCHONDO
;;; contact : hatchond@yahoo.fr
;;;
;;; This program is free software; you can redistribute it and/or
...
...
widgets.lisp
View file @
ff6838b0
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: widgets.lisp,v 1.4
2
2004/1
1/30 23:4
8:
1
0 ihatchondo Exp $
;;; $Id: widgets.lisp,v 1.4
3
2004/1
2/20 19:1
8:
2
0 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
...
...
@@ -62,8 +62,25 @@
(
defgeneric
put-on-bottom
(
widget
)
(
:documentation
"Sets the widget stacking order on bottom of the others \(except if any
widget with :_net_wm_type_desktop is present and widget is or an
application or a decoration\)."
))
widget with :_net_wm_type_desktop is present and widget is or an
application or a decoration\)."
))
(
defgeneric
maximize
(
widget
code
&key
fill-p
)
(
:method
(
widget
code
&key
fill-p
)
(
declare
(
ignorable
widget
code
fill-p
)))
(
:documentation
"Maximize/Unmaximize a widget. If already maximized then
restores the sizes of the widget before its maximization. During
maximization the widget will be enlarged to cover the whole screen except
any existing panels (e.g applications with the :_net_wm_window_type_dock
atom present in there _net_wm_window_type property.
widget (base-widget): the widget to (un)maximize.
code (integer 1 3):
1 operates on width and height.
2 operates on height.
3 operates on width.
:fill-p (boolean): If NIL, cover the whole screen (except dock type
applications). If T, finds the first region of the screen that does
not overlap applications not already overlapped by the widget."
))
(
defgeneric
shade
(
widget
)
(
:documentation
"shade/un-shade an application that is decorated."
))
...
...
@@ -83,14 +100,14 @@
(
:method
(
widget
theme-name
focus
)
nil
)
(
:documentation
"This method is dedicated to widget repaint such as every buttons, icons,
edges ...
It is specialized on widget type, theme name (via an eql specializer) and a
boolean that indicate if the corresponding toplevel (type decoration) is or
not focused.
edges ...
It is specialized on widget type, theme name (via an eql specializer) and a
boolean that indicate if the corresponding toplevel (type decoration) is or
not focused.
Except for standard expose events, the repaint dispatching on focus change
will be perform according to parts-to-redraw-on-focus list given in
define-theme."
))
Except for standard expose events, the repaint dispatching on focus change
will be perform according to parts-to-redraw-on-focus list given in
define-theme."
))
(
defmethod
initialize-instance
:after
((
widget
base-widget
)
&rest
rest
)
(
declare
(
ignore
rest
))
...
...
@@ -186,6 +203,9 @@
(
dialogs
:initform
nil
:writer
(
setf
application-dialogs
))))
(
defmethod
application-dialogs
((
application
application
))
"Returns all dialog applications of an application (including dialog of a
dialog). If this application is a transient-for (ICCCM 4.1.2.6) then the
returned list is the dialogs of its leader."
(
labels
((
find-all-dialogs
(
leader
)
(
loop
for
dialog
in
(
reverse
(
slot-value
leader
'dialogs
))
append
(
cons
dialog
(
find-all-dialogs
dialog
)))))
...
...
@@ -261,6 +281,86 @@
(
and
(
if
max-w
(
=
max-w
(
screen-width
))
t
)
(
if
max-h
(
=
max-h
(
screen-height
))
t
))))))
;; Maximization helpers.
(
defun
find-max-geometry
(
application
direction
fill-p
&key
x
y
w
h
)
(
multiple-value-bind
(
ulx
uly
lrx
lry
)
(
find-largest-empty-area
application
:area-include-me-p
(
or
(
/=
1
direction
)
fill-p
)
:panels-only-p
(
not
fill-p
)
:direction
(
case
direction
(
2
:vertical
)
(
3
:horizontal
)
(
t
:both
)))
(
with-slots
(
window
master
)
application
(
with-slots
((
hm
hmargin
)
(
vm
vmargin
))
(
if
master
(
decoration-frame-style
master
)
(
theme-default-style
(
lookup-theme
"no-decoration"
)))
(
symbol-macrolet
((
minw
(
aref
wmsh
0
))
(
minh
(
aref
wmsh
1
))
(
maxw
(
aref
wmsh
2
))
(
maxh
(
aref
wmsh
3
))
(
incw
(
aref
wmsh
4
))
(
inch
(
aref
wmsh
5
))
(
basew
(
aref
wmsh
6
))
(
baseh
(
aref
wmsh
7
)))
(
let*
((
wmsh
(
recompute-wm-normal-hints
window
hm
vm
))
(
ww
(
or
w
(
check-size
(
-
lrx
ulx
hm
)
basew
incw
minw
maxw
)))
(
hh
(
or
h
(
check-size
(
-
lry
uly
vm
)
baseh
inch
minh
maxh
))))
(
when
(
>
(
+
ww
hm
)
(
-
lrx
ulx
))
(
decf
ww
incw
))
(
when
(
>
(
+
hh
vm
)
(
-
lry
uly
))
(
decf
hh
inch
))
(
make-geometry
:w
ww
:h
hh
:x
(
or
x
ulx
)
:y
(
or
y
uly
))))))))
(
defun
compute-max-geometry
(
application
x
y
w
h
direction
fill-p
vert-p
horz-p
)
(
symbol-macrolet
((
ix
(
geometry-x
initial-geometry
))
(
iy
(
geometry-y
initial-geometry
))
(
iw
(
geometry-w
initial-geometry
))
(
ih
(
geometry-h
initial-geometry
)))
(
with-slots
(
initial-geometry
)
application
(
case
direction
;; Unmaximize or Maximize in both directions
(
1
(
if
(
or
horz-p
vert-p
)
(
copy-geometry
initial-geometry
)
(
find-max-geometry
application
direction
fill-p
)))
;; Unmaximize or Maximize Vertically
(
2
(
if
vert-p
(
make-geometry
:x
x
:y
iy
:w
w
:h
ih
)
(
find-max-geometry
application
direction
fill-p
:x
x
:w
w
)))
;; Unmaximize or Maximize Horizontally
(
3
(
if
horz-p
(
make-geometry
:x
ix
:y
y
:w
iw
:h
h
)
(
find-max-geometry
application
direction
fill-p
:y
y
:h
h
)))))))
(
defmethod
maximize
(
application
code
&key
(
fill-p
*maximize-fill*
))
(
with-slots
((
app-window
window
)
initial-geometry
full-geometry
master
)
application
(
when
(
shaded-p
master
)
(
shade
master
))
(
let*
((
new-g
)
(
m-window
(
if
master
(
widget-window
master
)
app-window
))
(
prop
(
netwm:net-wm-state
app-window
))
(
fullscreen-p
(
member
:_net_wm_state_fullscreen
prop
))
(
vert-p
(
car
(
member
:_net_wm_state_maximized_vert
prop
)))
(
horz-p
(
car
(
member
:_net_wm_state_maximized_horz
prop
))))
(
multiple-value-bind
(
x
y
)
(
window-position
m-window
)
(
multiple-value-bind
(
w
h
)
(
drawable-sizes
app-window
)
(
unless
(
or
horz-p
vert-p
)
(
if
fullscreen-p
(
setf
initial-geometry
(
copy-geometry
full-geometry
))
(
setf
(
geometry
initial-geometry
)
(
values
x
y
w
h
))))
(
setf
new-g
(
compute-max-geometry
application
x
y
w
h
code
fill-p
vert-p
horz-p
))))
;; Updates net-wm-state property content.
(
when
(
and
(
=
1
code
)
(
or
horz-p
vert-p
))
(
setf
(
values
horz-p
vert-p
)
(
values
t
t
)))
(
unless
(
=
3
code
)
(
if
vert-p
(
setf
prop
(
delete
:_net_wm_state_maximized_vert
prop
))
(
pushnew
:_net_wm_state_maximized_vert
prop
)))
(
unless
(
=
2
code
)
(
if
horz-p
(
setf
prop
(
delete
:_net_wm_state_maximized_horz
prop
))
(
pushnew
:_net_wm_state_maximized_horz
prop
)))
;; Resize.
(
if
fullscreen-p
(
setf
full-geometry
new-g
)
(
setf
(
window-position
m-window
)
(
geometry-coordinates
new-g
)
(
drawable-sizes
app-window
)
(
geometry-sizes
new-g
)))
;; Update property.
(
setf
(
netwm:net-wm-state
app-window
)
prop
))))
(
defsetf
fullscreen-mode
(
application
)
(
mode
)
"Mode may be (or :on :off). Put or remove application in or from fullscreen."
`
(
with-slots
(
window
(
fgeometry
full-geometry
)
master
icon
)
,
application
...
...
@@ -303,13 +403,13 @@
(
defun
application-leader
(
application
)
"Returns the \"leader\" of an application. The leader is computed
recursively from the transient-for application hint."
recursively from the transient-for application hint."
(
with-slots
(
transient-for
)
application
(
if
transient-for
(
application-leader
transient-for
)
application
)))
(
defun
migrate-application
(
application
new-screen-number
)
"Put an application, all its related dialogs and the top-level it is
transient-for (if any) to the a new virtual screen."
transient-for (if any) to the a new virtual screen."
(
with-slots
(
master
window
transient-for
)
application
(
let*
((
focused-p
(
focused-p
application
))
(
unmap-p
(
/=
new-screen-number
+any-desktop+
(
current-desk
)))
...
...
@@ -317,7 +417,7 @@
(
flet
((
migrate
(
application
)
(
with-slots
(
master
window
)
application
(
when
(
shaded-p
application
)
(
shade
application
))
(
setf
(
window-desktop-num
window
)
new-screen-number
)
(
setf
(
window-desktop-num
window
)
new-screen-number
)
(
with-event-mask
(
*root-window*
)
(
let
((
master-window
(
when
master
(
widget-window
master
))))
(
funcall
operation
(
or
master-window
window
))
...
...
@@ -332,6 +432,7 @@
(
give-focus-to-next-widget-in-desktop
)))))))
(
defun
undecore-application
(
application
&key
state
)
"Removes all decoration of this application widget and reparent it to root."
(
with-slots
(
window
master
icon
)
application
(
if
master
(
multiple-value-bind
(
x
y
)
...
...
@@ -344,6 +445,9 @@
(
delete-properties
window
+properties-to-delete-on-withdrawn+
)))))
(
defun
computes-transient-for
(
application
)
"Sets and returns the transient-for slot of an application. If this
application is a transient-for (ICCCM 4.1.2.6) then it will be added to
the dialogs list of its leader."
(
with-slots
(
transient-for
(
win
window
))
application
(
let
((
transient
(
lookup-widget
(
ignore-errors
(
xlib:transient-for
win
)))))
(
setf
transient-for
...
...
@@ -363,6 +467,10 @@
((
and
input-p
take-focus-p
)
:locally-active
))))
(
defun
make-initital-geometry
(
window
&optional
(
geometry
(
make-geometry
)))
"Returns the initial-geometry of a window. The initial geometry will be
computed according to the wm-normal-hints property if present or to the
actual geometry of the specified window. If the optional geometry is
given then it will be filled and returned."
(
multiple-value-bind
(
x
y
w
h
)
(
window-geometry
window
)
(
let
((
hint
(
ignore-errors
(
xlib:wm-normal-hints
window
))))
(
setf
(
geometry
geometry
)
...
...
@@ -515,7 +623,7 @@
(
defun
timed-message-box
(
window
&rest
messages
)
"Map a small box, of parent `window', displaying the given string messages.
This box will automatically destroyed two seconds after being mapped."
This box will automatically destroyed two seconds after being mapped."
(
with-slots
(
window
)
(
create-message-box
messages
:parent
window
)
(
xlib:map-window
window
)
(
pt:arm-timer
2
(
lambda
()
...
...
@@ -763,7 +871,7 @@
(
setq
prev-icon-window
icon-window
)))))))
(
defsetf
icon-priority
(
icon
)
(
priority
)
"
r
estack the window of the given icon according the given priority."
"
R
estack the window of the given icon according the given priority."
(
with-gensym
(
p
sibling
)
`
(
let
((
,
p
,
priority
)
,
sibling
)
(
when
(
eq
,
priority
:below
)
...
...
wm.lisp
View file @
ff6838b0
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: wm.lisp,v 1.4
5
2004/
03/19 15:09
:4
5
ihatchondo Exp $
;;; $Id: wm.lisp,v 1.4
6
2004/
12/16 21:36
:4
7
ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
...
...
@@ -39,24 +39,28 @@
(
application-gravity
:initarg
:application-gravity
:initform
:north-west
:accessor
decoration-application-gravity
)
))
:accessor
decoration-application-gravity
))
(
:documentation
"Top level widget for application that will have a set of
decoration (e.g: those for which window-not-decorable-p will return NIL)."
))
(
defun
decoration-p
(
widget
)
(
typep
widget
'decoration
))
(
defun
title-bar-horizontal-p
(
master
)
(
eq
:horizontal
(
style-title-bar-direction
(
decoration-frame-style
master
))))
(
defconstant
+decoration-event-mask+
'
(
:substructure-redirect
:substructure-notify
:visibility-change
:enter-window
:owner-grab-button
))
(
defmethod
get-child
((
master
decoration
)
label
&key
window
)
"Return the child widget/window labeled `label' or nil if no such
"Return
s
the child widget/window labeled `label' or nil if no such
child exists. label is a keyword."
(
let
((
widget
(
getf
(
decoration-children
master
)
label
)))
(
if
(
and
widget
window
)
(
widget-window
widget
)
widget
)))
(
defmethod
decoration-wm-hints
((
master
decoration
))
"
r
eturn as a multiple value: minw minh maxw maxh incw inch basew baseh."
"
R
eturn
s
as a multiple value: minw minh maxw maxh incw inch basew baseh."
(
with-slots
(
frame-style
(
wmsh
wm-size-hints
))
master
(
declare
(
type
(
vector
integer
8
)
wmsh
))
(
with-slots
((
hm
hmargin
)
(
vm
vmargin
))
frame-style
...
...
@@ -108,6 +112,18 @@
(
setf
(
netwm:net-wm-state
app-win
)
netwm-prop
(
gnome:win-state
app-win
)
gnome-prop
))))
(
defmethod
close-widget
((
widget
decoration
))
(
close-widget
(
get-child
widget
:application
)))
(
defmethod
put-on-top
((
widget
decoration
))
(
put-on-top
(
get-child
widget
:application
)))
(
defmethod
put-on-bottom
((
widget
decoration
))
(
put-on-bottom
(
get-child
widget
:application
)))
(
defmethod
maximize
((
widget
decoration
)
code
&key
(
fill-p
*maximize-fill*
))
(
maximize
(
get-child
widget
:application
)
code
:fill-p
fill-p
))
(
defmethod
(
setf
decoration-frame-style
)
:after
(
astyle
(
master
decoration
))
(
with-slots
(
window
children
wm-size-hints
)
master
(
with-slots
(
left-margin
top-margin
(
hm
hmargin
)
(
vm
vmargin
))
astyle
...
...
@@ -139,15 +155,6 @@
((
application-iconic-p
application
)
(
xlib:unmap-window
app-win
))))))))
(
defmethod
close-widget
((
widget
decoration
))
(
close-widget
(
get-child
widget
:application
)))
(
defmethod
put-on-top
((
widget
decoration
))
(
put-on-top
(
get-child
widget
:application
)))
(
defmethod
put-on-bottom
((
widget
decoration
))
(
put-on-bottom
(
get-child
widget
:application
)))
(
defmethod
dispatch-repaint
((
master
decoration
)
&key
(
focus
(
focused-p
master
)))
(
declare
(
optimize
(
speed
3
)
(
safety
1
)))
...
...
@@ -156,10 +163,11 @@
(
mapc
#'
(
lambda
(
k
)
(
repaint
(
get-child
master
k
)
name
focus
))
parts-to-redraw-on-focus
)))
(
defun
title-bar-horizontal-p
(
master
)
(
eq
:horizontal
(
style-title-bar-direction
(
decoration-frame-style
master
))))
(
defun
recompute-wm-normal-hints
(
window
hmargin
vmargin
)
"Returns two value: a vector representing the wm-normal-hints property and
the window gravity of the designed window. The wm-normal-hints property is
recomputed in order to reflect the margin that a top level decoration widget
(aka master) might introduce."
(
let
((
hints
(
or
(
ignore-errors
(
xlib:wm-normal-hints
window
))
(
xlib:make-wm-size-hints
)))
(
max-ww
(
screen-width
))
...
...
@@ -370,6 +378,7 @@
(
values
(
max
0
(
-
x
left-margin
))
(
max
0
(
-
y
top-margin
))))))))
(
defun
make-decoration
(
app-window
application
&key
theme
)
"Returns a newly initialized decoration to hold the given application."
(
unless
theme
(
setf
theme
(
root-decoration-theme
*root*
)))
(
let*
((
dstyle
(
find-decoration-frame-style
theme
app-window
))
(
style
dstyle
))
...
...
@@ -406,9 +415,9 @@
master
)))))))
(
defun
decore-application
(
window
application
&key
(
map
t
)
theme
)
"Decore an application and map the resulting decoration as indicated
"Decore
s
an application and map the resulting decoration as indicated
by the :map keyword argument. (default value is T).
Return the newly created decoration."
Return
s
the newly created decoration
instance
."
(
let*
((
master
(
make-decoration
window
application
:theme
theme
))
(
master-window
(
widget-window
master
))
(
left-margin
(
style-left-margin
(
decoration-frame-style
master
)))
...
...
@@ -420,86 +429,6 @@
(
when
map
(
xlib:map-window
window
))
master
))
;;;; Maximization tools.
(
defun
find-max-geometry
(
application
direction
fill-p
&key
x
y
w
h
)
(
multiple-value-bind
(
ulx
uly
lrx
lry
)
(
find-largest-empty-area
application
:area-include-me-p
(
or
(
/=
1
direction
)
fill-p
)
:panels-only-p
(
not
fill-p
)
:direction
(
case
direction
(
2
:vertical
)
(
3
:horizontal
)
(
t
:both
)))
(
with-slots
(
window
master
)
application
(
with-slots
((
hm
hmargin
)
(
vm
vmargin
))
(
if
master
(
decoration-frame-style
master
)
(
theme-default-style
(
lookup-theme
"no-decoration"
)))
(
symbol-macrolet
((
minw
(
aref
wmsh
0
))
(
minh
(
aref
wmsh
1
))
(
maxw
(
aref
wmsh
2
))
(
maxh
(
aref
wmsh
3
))
(
incw
(
aref
wmsh
4
))
(
inch
(
aref
wmsh
5
))
(
basew
(
aref
wmsh
6
))
(
baseh
(
aref
wmsh
7
)))
(
let*
((
wmsh
(
recompute-wm-normal-hints
window
hm
vm
))
(
ww
(
or
w
(
check-size
(
-
lrx
ulx
hm
)
basew
incw
minw
maxw
)))
(
hh
(
or
h
(
check-size
(
-
lry
uly
vm
)
baseh
inch
minh
maxh
))))
(
when
(
>
(
+
ww
hm
)
(
-
lrx
ulx
))
(
decf
ww
incw
))
(
when
(
>
(
+
hh
vm
)
(
-
lry
uly
))
(
decf
hh
inch
))
(
make-geometry
:w
ww
:h
hh
:x
(
or
x
ulx
)
:y
(
or
y
uly
))))))))
(
defun
compute-max-geometry
(
application
x
y
w
h
direction
fill-p
vert-p
horz-p
)
(
symbol-macrolet
((
ix
(
geometry-x
initial-geometry
))
(
iy
(
geometry-y
initial-geometry
))
(
iw
(
geometry-w
initial-geometry
))
(
ih
(
geometry-h
initial-geometry
)))
(
with-slots
(
initial-geometry
)
application
(
case
direction
;; Unmaximize or Maximize in both directions
(
1
(
if
(
or
horz-p
vert-p
)
(
copy-geometry
initial-geometry
)
(
find-max-geometry
application
direction
fill-p
)))
;; Unmaximize or Maximize Vertically
(
2
(
if
vert-p
(
make-geometry
:x
x
:y
iy
:w
w
:h
ih
)
(
find-max-geometry
application
direction
fill-p
:x
x
:w
w
)))
;; Unmaximize or Maximize Horizontally
(
3
(
if
horz-p
(
make-geometry
:x
ix
:y
y
:w
iw
:h
h
)
(
find-max-geometry
application
direction
fill-p
:y
y
:h
h
)))))))
;; Public.
(
defun
maximize-window
(
application
code
&key
(
fill-p
*maximize-fill*
))
(
with-slots
((
app-window
window
)
initial-geometry
full-geometry
master
)
application
(
when
(
shaded-p
master
)
(
shade
master
))
(
let*
((
new-g
)
(
m-window
(
if
master
(
widget-window
master
)
app-window
))
(
prop
(
netwm:net-wm-state
app-window
))
(
fullscreen-p
(
member
:_net_wm_state_fullscreen
prop
))
(
vert-p
(
car
(
member
:_net_wm_state_maximized_vert
prop
)))
(
horz-p
(
car
(
member
:_net_wm_state_maximized_horz
prop
))))
(
multiple-value-bind
(
x
y
)
(
window-position
m-window
)
(
multiple-value-bind
(
w
h
)
(
drawable-sizes
app-window
)
(
unless
(
or
horz-p
vert-p
)
(
if
fullscreen-p
(
setf
initial-geometry
(
copy-geometry
full-geometry
))
(
setf
(
geometry
initial-geometry
)
(
values
x
y
w
h
))))
(
setf
new-g
(
compute-max-geometry
application
x
y
w
h
code
fill-p
vert-p
horz-p
))))
(
when
(
and
(
=
1
code
)
(
or
horz-p
vert-p
))
(
setf
(
values
horz-p
vert-p
)
(
values
t
t
)))
(
unless
(
=
3
code
)
(
if
vert-p
(
setf
prop
(
delete
:_net_wm_state_maximized_vert
prop
))
(
pushnew
:_net_wm_state_maximized_vert
prop
)))
(
unless
(
=
2
code
)
(
if
horz-p
(
setf
prop
(
delete
:_net_wm_state_maximized_horz
prop
))
(
pushnew
:_net_wm_state_maximized_horz
prop
)))
(
if
fullscreen-p
(
setf
full-geometry
new-g
)
(
setf
(
window-position
m-window
)
(
geometry-coordinates
new-g
)
(
drawable-sizes
app-window
)
(
geometry-sizes
new-g
)))
(
setf
(
netwm:net-wm-state
app-window
)
prop
))))
;;;; Focus management. According to ICCCM
(
defgeneric
set-focus
(
input-model
window
timestamp
)
...
...
@@ -666,7 +595,7 @@
(
if
(
stick-p
appw
)
(
cons
"Un-pin"
(
send-message
(
current-desk
)))
(
cons
"Pin "
(
send-message
+any-desktop+
)))
(
cons
max-str
(
lambda
()
(
maximize
-window
app
1
)))
(
cons
max-str
(
lambda
()
(
maximize
app
1
)))
(
cons
shade-str
(
lambda
()
(
shade
master
)))
(
cons
"Close "
(
lambda
()
(
close-widget
app
)))
(
cons
"Destroy"
(
lambda
()
(
kill-client-window
appw
)))
...
...
@@ -710,7 +639,7 @@
(
1
(
add-window-in-client-lists
appw
root
))))))
(
defun
window-not-decorable-p
(
window
&optional
type
)
"Return T if a window `should' not be decorated. Typically, a splash screen,
"Return
s
T if a window `should' not be decorated. Typically, a splash screen,
a desktop (e.g. nautilus) or a dock (e.g. gnome panels) will be assumed as
non-decorable windows, as well as windows holding the motif_wm_hints with the
flag `no decoration at all'."
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment