p009.lisp 3.38 KB
Newer Older
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
(in-package :gdl)

(defparameter *1588p009-doc* 
  "Makes web-drawing and tasty respect background and foreground in *colors-default*.")


(#+allegro 
 excl:without-package-locks #-allegro progn
 (#+allegro 
  excl:without-redefinition-warnings
  #-allegro progn

  (defmethod lookup-color ((color null) &key (format :decimal) (ground :foreground))
    (unless (and (eql ground :foreground)
		 (eql (getf *colors-default* :foreground) :black))
      (values (lookup-color (getf *colors-default* ground) :format format) nil)))))

(in-package :geom-base)

(#+allegro 
 excl:without-package-locks #-allegro progn
 (#+allegro 
  excl:without-redefinition-warnings
  #-allegro progn

  (define-lens  (pdf base-object) ()
    :amend? t
    :output-functions
    ((rgb-stroke-setting
      ()
      (let* ((display-controls (find-in-hash self *display-controls*))
	     (color (or (getf display-controls :color)
			(the color-decimal)))
	     (color-decimal (if (consp color) color 
				(coerce (lookup-color (or color (format-slot foreground-color))) 'list)))
	     (fill-color-decimal (coerce (lookup-color (getf (the display-controls) :fill-color)) 'list)))
      
	(apply #'pdf:set-rgb-stroke color-decimal)
	(apply #'pdf:set-rgb-fill (or fill-color-decimal color-decimal))))))


  (define-object-amendment base-object ()
    :computed-slots
    ((color-decimal (lookup-color (getf (the display-controls) :color)))))))
   
	   

(in-package :raphael)


(#+allegro 
 excl:without-package-locks #-allegro progn
 (#+allegro 
  excl:without-redefinition-warnings
  #-allegro progn

  (define-lens (raphael base-drawing) ()
    :amend? t
    :output-functions
    ((raphael-paper-def
    (&key width length)
    (format *stream* "var paper = Raphael('~a', ~a, ~a);

               paper.canvas.style.backgroundColor = '~a';


               if (typeof start === 'undefined') {

                var start = function () {
                    this.lastdx ? this.odx += this.lastdx : this.odx = 0;
                    this.lastdy ? this.ody += this.lastdy : this.ody = 0;
                    this.animate({opacity: .5}, 500, \">\");
                },


                move_cb = function (dx, dy) {
                    this.transform(\"T\"+(dx+this.odx)+\",\"+(dy+this.ody));
                    this.lastdx = dx;
                    this.lastdy = dy;
                    this.animate({opacity: .5}, 500, \">\");
                    ~a 
                },

                move = function (dx, dy) {
                    this.transform(\"T\"+(dx+this.odx)+\",\"+(dy+this.ody));
                    this.lastdx = dx;
                    this.lastdy = dy;
                    this.animate({opacity: .5}, 500, \">\");
                },

                up = function () {
                    this.animate({opacity: 1.0}, 500, \">\");
                    ~a 
                },

                  touchcoords = function () {~a}};

"
	    (the raphael-canvas-id) width length

	    (lookup-color (format-slot background-color) :format :hex)

	    ;;
	    ;; FLAG -- pass in the containing
	    ;; base-ajax-graphics-sheet and refer
	    ;; to that, instead of referring to
	    ;; the parent here.
	    ;;
	    (the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-drag))
	    (the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-drop))

	    (the parent (gdl-sjax-call :null-event? t :js-vals? t :function-key :on-touchmove))))))))