This file is indexed.

/usr/lib/gcl-2.6.12/gcl-tk/demos/mkRuler.lisp is in gcl 2.6.12-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  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
;;# mkRuler w
;;
;; Create a canvas demonstration consisting of a ruler.
;;
;; Arguments:
;;    w -	Name to use for new top-level window.
;; This file implements a canvas widget that displays a ruler with tab stops
;; that can be set individually.  The only procedure that should be invoked
;; from outside the file is the first one, which creates the canvas.

(in-package "TK")

(defun mkRuler (&optional (w '.ruler)) 
    (if (winfo :exists w :return 'boolean) (destroy w))
    (toplevel w)
    (dpos w)
    (wm :title w "Ruler Demonstration")
    (wm :iconname w "Ruler")
    (setq c (conc w '.c))

    (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal-*-180-* :width "13c" 
	    :relief "raised" :bd 2 :text "This canvas widget shows a mock-up of a ruler.  You can create tab stops by dragging them out of the well to the right of the ruler.  You can also drag existing tab stops.  (if :you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button.")
    (canvas c :width "14.8c" :height "2.5c" :relief "raised")
    (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w))
    (pack (conc w '.msg) (conc w '.c) :side "top" :fill "x")
    (pack (conc w '.ok) :side "bottom" :pady 5)
    (setf *v* (gensym))
    (setf (get *v* 'grid) '.25c)
    (setf (get *v* 'left) (winfo :fpixels c "1c" :return t))
    (setf (get *v* 'right) (winfo :fpixels c "13c" :return t))
    (setf (get *v* 'top) (winfo :fpixels c "1c" :return t))
    (setf (get *v* 'bottom) (winfo :fpixels c "1.5c" :return t))
    (setf (get *v* 'size) (winfo :fpixels c '.2c :return t))
    (setf (get *v* 'normalStyle) '(:fill "black"))
    (if (> (read-from-string (winfo :depth c)) 1)
	(progn 
	  (setf (get *v* 'activeStyle) '(:fill "red" :stipple ""))
	  (setf (get *v* 'deleteStyle)
		`(:stipple "@" : ,*tk-library* :"/demos/bitmaps/grey.25" 
			   :fill "red"))
	  );;else 
      (progn 
	(setf (get *v* 'activeStyle) '(:fill "black" :stipple "" ))
	(setf (get *v* 'deleteStyle)
	      `(:stipple "@" : ,*tk-library* : "/demos/bitmaps/grey.25"
			 :fill "black"))
	))

    (funcall c :create "line" "1c" "0.5c" "1c" "1c" "13c" "1c" "13c" "0.5c" :width 1)
    (dotimes
     (i  12)
     (let (( x (+ i 1)))
       (funcall c :create "line" x :"c" "1c" x :"c" "0.6c" :width 1)
       (funcall c :create "line" x :".25c" "1c"  x :".25c" "0.8c" :width 1)
       (funcall c :create "line"  x :".5c" "1c"  x :".5c" "0.7c" :width 1)
       (funcall c :create "line"  x :".75c" "1c"  x :".75c" "0.8c" :width 1)
       (funcall c :create "text"  x :".15c" '.75c :text i :anchor "sw")
       ))
    (funcall c :addtag "well" "withtag"
	     (funcall c :create "rect" "13.2c" "1c" "13.8c" "0.5c" 
		      :outline "black" :fill
		      (nth 4 (funcall c :config :background
				      :return 'list-strings))))
    (funcall c :addtag "well" "withtag"
	     (rulerMkTab c (winfo :pixels c "13.5c" :return t)
			 (winfo :pixels c '.65c :return t)))

    (funcall c :bind "well" "<1>" `(rulerNewTab ',c |%x| |%y|))
    (funcall c :bind "tab" "<1>" `(demo_selectTab  ',c |%x| |%y|))
    (bind c "<B1-Motion>" `(rulerMoveTab ',c |%x| |%y|))
    (bind c "<Any-ButtonRelease-1>" `(rulerReleaseTab ',c))
)

(defun rulerMkTab (c x y) 

    (funcall c :create "polygon" x y (+ x (get *v* 'size))
	     (+ y (get *v* 'size))
	     (- x (get *v* 'size))
	     (+ y (get *v* 'size))
	     :return 'string
	     )

)

(defun rulerNewTab (c x y) 

    (funcall c :addtag "active" "withtag" (rulerMkTab c x y))
    (funcall c :addtag "tab" "withtag" "active")
    (setf (get *v* 'x) x)
    (setf (get *v* 'y) y)
    (rulerMoveTab c x y)
)
(defvar *recursive* nil)
;; prevent recursive calls
(defun rulerMoveTab (c x y &aux cx cy (*recursive* *recursive*) )
  (cond (*recursive* (return-from rulerMoveTab))
	(t (setq *recursive* t)))
  (if (equal (funcall c :find "withtag" "active" :return 'string) "")
      (return-from rulerMoveTab nil))
  (setq cx (funcall c :canvasx x (get *v* 'grid) :return t))
  (setq cy (funcall c :canvasy y :return t))
  (if (<  cx  (get *v* 'left))(setq cx (get *v* 'left)))
  (if (> cx  (get *v* 'right))(setq cx (get *v* 'right)))

  (if (and (>= cy (get *v* 'top)) (<= cy (get *v* 'bottom)))
      (progn 
	(setq cy (+ 2 (get *v* 'top)))
	(apply c :itemconf "active" (get *v* 'activestyle)))
    
    (progn 
      (setq cy (- cy (get *v* 'size) 2))
      (apply c :itemconf "active"(get *v* 'deletestyle)))
    )
  (funcall c :move "active" (- cx (get *v* 'x))
	   (- cy (get *v* 'y)) )
  (setf (get *v* 'x) cx)
  (setf (get *v* 'y) cy)
  )

(defun demo_selectTab (c x y) 

    (setf (get *v* 'x) (funcall c :canvasx x (get *v* 'grid) :return t))
    (setf (get *v* 'y) (+ 2  (get *v* 'top)))
    (funcall c :addtag "active" "withtag" "current")
    (apply  c :itemconf "active" (get *v* 'activeStyle))
    (funcall c :raise "active")
)

(defun rulerReleaseTab (c )

    (if (equal (funcall c :find "withtag" "active" :return 'string)
	       "") (return-from rulerReleaseTab nil))

    (if (not (eql (get *v* 'y) (+ 2 (get *v* 'top))))
	(funcall c :delete "active")
     (progn
	(apply c :itemconf "active" (get *v* 'normalStyle))
	(funcall c :dtag "active")
    )
))