simple-test.lisp 2.54 KB
Newer Older
cer's avatar
fixes    
cer committed
1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
cer's avatar
fixes    
cer committed
2
;;
3
;;
4
;; See the file LICENSE for the full license governing this code.
cer's avatar
fixes    
cer committed
5
6
;;

7
8
;; #-acl86win32
;; (defpackage :clim-user (:use :clim-silica))
cer's avatar
fixes  
cer committed
9

cer's avatar
fixes    
cer committed
10
11
(in-package :clim-user)

cer's avatar
fixes    
cer committed
12

cer's avatar
fixes    
cer committed
13
14
15
16
17
(defclass simple-test-sheet (silica::permanent-medium-sheet-output-mixin
			     silica::sheet-multiple-child-mixin
			     silica::sheet-transformation-mixin
			     silica::standard-repainting-mixin
			     silica::immediate-sheet-input-mixin
cer's avatar
fixes    
cer committed
18
			     silica::basic-sheet)
cer's avatar
fixes    
cer committed
19
20
  ())

cer's avatar
fixes    
cer committed
21
22
(defmethod sheet-event-queue ((sheet simple-test-sheet)) nil)

cer's avatar
fixes    
cer committed
23
(defclass even-simpler (simple-test-sheet) ())
cer's avatar
fixes  
cer committed
24

cer's avatar
fixes    
cer committed
25
26
27
(defun simple-test ()
  (let* ((port (find-port))
	 (graft (find-graft))
cer's avatar
fixes    
cer committed
28
29
30
	 (sheet (make-instance 'silica::standard-mirrored-sheet
		  :parent graft
		  :region (make-bounding-rectangle 0 0 300 300))))
cer's avatar
fixes    
cer committed
31
32
    (dotimes (i 5)
      (dotimes (j 5)
cer's avatar
fixes    
cer committed
33
	(let ((s (make-instance 'simple-test-sheet
cer's avatar
fixes    
cer committed
34
35
36
		   :parent sheet
		   :region (make-bounding-rectangle 0 0 60 60)
		   :transformation (make-translation-transformation (* i 60) (* j 60)))))
cer's avatar
fixes    
cer committed
37
38
	  (setf (sheet-enabled-p s) t)
	  (let ((s2 (make-instance 'even-simpler
cer's avatar
fixes    
cer committed
39
40
41
		      :parent s
		      :region (make-bounding-rectangle 0 0 40 40)
		      :transformation (make-translation-transformation 10 10))))
cer's avatar
fixes    
cer committed
42
43
44
	    (setf (sheet-enabled-p s2) t)))))
    (setf (sheet-enabled-p sheet) t)
    sheet))
cer's avatar
fixes  
cer committed
45

cer's avatar
fixes    
cer committed
46
(defmethod handle-event ((sheet simple-test-sheet) (event pointer-enter-event))
cer's avatar
fixes    
cer committed
47
  (outline-sheet sheet)
cer's avatar
cer committed
48
  (setf (port-keyboard-input-focus (port sheet)) sheet))
cer's avatar
fixes  
cer committed
49

cer's avatar
fixes    
cer committed
50
51
(defun outline-sheet (sheet)
  (with-bounding-rectangle* (a b c d) sheet
52
    (draw-rectangle* sheet
cer's avatar
fixes    
cer committed
53
54
55
		     a b (1- c) (1- d)
		     :filled nil
		     :ink +flipping-ink+)))
cer's avatar
fixes  
cer committed
56

cer's avatar
fixes    
cer committed
57
(defmethod handle-event ((sheet simple-test-sheet) (event pointer-exit-event))
cer's avatar
fixes    
cer committed
58
  (outline-sheet sheet))
cer's avatar
fixes    
cer committed
59

cer's avatar
fixes    
cer committed
60
(defmethod handle-event ((sheet simple-test-sheet) (event pointer-button-event))
cer's avatar
fixes    
cer committed
61
62
63
64
  (multiple-value-call #'draw-rectangle*
		       sheet
		       (bounding-rectangle* sheet)
		       :ink +flipping-ink+))
cer's avatar
fixes    
cer committed
65

cer's avatar
fixes    
cer committed
66
(defmethod handle-event ((sheet simple-test-sheet) (event keyboard-event))
cer's avatar
fixes    
cer committed
67
68
69
  (draw-line* sheet -200 -200 200 200 :ink +flipping-ink+
	      :line-thickness 10))

cer's avatar
fixes    
cer committed
70
(defmethod handle-repaint ((sheet silica::standard-sheet) region)
cer's avatar
fixes    
cer committed
71
  (declare (ignore region))
cer's avatar
fixes    
cer committed
72
73
  )

cer's avatar
fixes    
cer committed
74
75
(defmethod handle-repaint ((sheet simple-test-sheet) region)
  (declare (ignore region))
cer's avatar
fixes    
cer committed
76
77
  )

cer's avatar
fixes    
cer committed
78
79
(defmethod handle-repaint ((sheet even-simpler) region)
  (declare (ignore region))
80
81
  (multiple-value-call #'draw-rectangle*
		       sheet
cer's avatar
fixes    
cer committed
82
83
84
		       (bounding-rectangle* sheet)
		       :filled t
		       :ink +red+))