File: workspace-geometry.jl

package info (click to toggle)
sawfish 1%3A1.3.5.2-2
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 11,636 kB
  • ctags: 1,327
  • sloc: lisp: 22,765; ansic: 15,810; sh: 10,203; makefile: 675; perl: 19
file content (151 lines) | stat: -rw-r--r-- 4,648 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
#| nokogiri-widgets/workspace-geometry.jl

   $Id: workspace-geometry.jl,v 1.9 2003/01/12 20:30:49 jsh Exp $

   Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>

   This file is part of sawfish.

   sawfish is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   sawfish is distributed in the hope that it will be useful, but
   WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with sawfish; see the file COPYING.  If not, write to
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|#

;; GNOME version of this widget

(define-structure sawfish.ui.widgets.workspace-geometry ()

    (open rep
	  gui.gtk-2.gtk
	  gui.gtk-2.gnome-canvas
	  rep.io.files
	  sawfish.gtk.widget
	  sawfish.ui.layout)

  (defconst canvas-width 100)
  (defconst canvas-height 100)

  (define (locate-file filename dirs)
    (let loop ((rest dirs))
      (cond ((null rest) nil)
	    ((file-exists-p (expand-file-name filename (car rest)))
	     (expand-file-name filename (car rest)))
	    (t (loop (cdr rest))))))

  (define monitor-pixbuf-file
    (local-file-name (locate-file "../monitor.png" load-path)))

  (define monitor-pixbuf (gdk-pixbuf-new-from-file monitor-pixbuf-file))

  (define (make-workspace-geometry-item changed-callback #!optional doc)
    (let* ((canvas (gnome-canvas-new))
	   (vbox (gtk-vbox-new nil box-spacing))
	   (hbox (gtk-hbox-new nil box-spacing))
	   canvas-items widget)

      (define (erase-canvas)
	(mapc gtk-object-destroy canvas-items)
	(setq canvas-items '()))

      (define (draw-line x1 y1 x2 y2)
	(let ((item (gnome-canvas-item-new (gnome-canvas-root canvas)
					   'GnomeCanvasLine
					   `(points ,(list x1 y1 x2 y2)
					     fill_color "black"
					     line_style on-off-dash))))
	  (setq canvas-items (cons item canvas-items))
	  item))

      (define (draw-rect x1 y1 x2 y2)
	(let ((item (gnome-canvas-item-new (gnome-canvas-root canvas)
					   'GnomeCanvasRect
					   (list 'x1 x1 'y1 y1
						 'x2 x2 'y2 y2
						 'fill_color "grey90"
						 'outline_color "black"))))
	  (setq canvas-items (cons item canvas-items))
	  item))

      (define (draw-image pixbuf x y)
	(let ((item (gnome-canvas-item-new (gnome-canvas-root canvas)
					   'GnomeCanvasPixbuf
					   (list 'pixbuf pixbuf
						 'x x 'y y))))
	  (setq canvas-items (cons item canvas-items))
	  item))

      (define (draw-canvas)
	(let* ((dims (widget-ref widget))
	       (spaces (car dims))
	       (port-dims (cdr dims)))
	  (let* ((space-step 10)
		 (space-size (- canvas-width (* (1- spaces) space-step)))
		 (x-step (floor (/ space-size (car port-dims))))
		 (y-step (floor (/ space-size (cdr port-dims)))))
	    (do ((i (1- spaces) (1- i)))
		((< i 0))
	      (draw-rect (* i space-step)
			 (* i space-step)
			 (+ (* i space-step) space-size)
			 (+ (* i space-step) space-size)))
	    (do ((i 1 (1+ i)))
		((= i (car port-dims)))
	      (draw-line (* i x-step) 0
			 (* i x-step) space-size))
	    (do ((i 1 (1+ i)))
		((= i (cdr port-dims)))
	      (draw-line 0 (* i y-step)
			 space-size (* i y-step)))
	    (draw-image (gdk-pixbuf-scale-simple monitor-pixbuf
						 (- x-step 4) (- y-step 4)
						 'bilinear) 2 2))))

      (define (update-canvas)
	(erase-canvas)
	(draw-canvas))

      (define (changed)
	(call-callback changed-callback)
	(update-canvas))

      (setq widget (make-widget
		    `(pair (labelled ,(_ "Workspaces:")
				     (number 1))
			   (pair (labelled ,(_ "Columns:") (number 1))
				 (labelled ,(_ "Rows:") (number 1))) t)
		    changed))

      (gtk-widget-set-usize canvas (+ canvas-width 10) (+ canvas-height 10))
      (gnome-canvas-set-scroll-region canvas 0 0 canvas-width canvas-height)

      (when doc
	(gtk-container-add vbox (make-label (remove-newlines doc))))
      (gtk-container-add vbox (widget-gtk-widget widget))
      (gtk-container-add hbox vbox)
      (gtk-container-add hbox canvas)
      (gtk-widget-show-all hbox)
      (draw-canvas)

      (lambda (op)
	(case op
	  ((gtk-widget) hbox)
	  ((set) (lambda (x)
		   (widget-set widget x)
		   (update-canvas)))
	  ((clear) (lambda (x)
		     (widget-clear widget)
		     (update-canvas)))
	  (t (widget op))))))

  (define-widget-type 'workspace-geometry make-workspace-geometry-item)
  (widget-accepts-doc-string 'workspace-geometry))