Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-imap.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; w3-imap.el,v --- Imagemap functions
2 ;; Author: wmperry
3 ;; Created: 1996/05/27 17:50:43
4 ;; Version: 1.19
5 ;; Keywords: hypermedia
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@spry.com)
9 ;;;
10 ;;; This file is part of GNU Emacs.
11 ;;;
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2, or (at your option)
15 ;;; any later version.
16 ;;;
17 ;;; GNU Emacs is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26
27 (require 'w3-vars)
28 (require 'widget)
29 (require 'widget-edit)
30
31 (eval-when-compile
32 (defmacro x-coord (pt) (list 'aref pt 0))
33 (defmacro y-coord (pt) (list 'aref pt 1)))
34
35 (defun w3-point-in-rect (point coord1 coord2 &rest ignore)
36 "Return t iff POINT is within a rectangle defined by COORD1 and COORD2.
37 All arguments are vectors of [X Y] coordinates."
38 ;; D'uhhh, this is hard.
39 (and (>= (x-coord point) (x-coord coord1))
40 (<= (x-coord point) (x-coord coord2))
41 (>= (y-coord point) (y-coord coord1))
42 (<= (y-coord point) (y-coord coord2))))
43
44 (defun w3-point-in-circle (point coord1 coord2 &rest ignore)
45 "Return t iff POINT is within a circle defined by COORD1 and COORD2.
46 All arguments are vectors of [X Y] coordinates."
47 ;; D'uhhh, this is (barely) slightly harder.
48 (let (radius1 radius2)
49 (setq radius1 (+
50 (*
51 (- (y-coord coord1) (y-coord coord2))
52 (- (y-coord coord1) (y-coord coord2)))
53 (*
54 (- (x-coord coord1) (x-coord coord2))
55 (- (x-coord coord1) (x-coord coord2)))
56 )
57 radius2 (+
58 (*
59 (- (y-coord coord1) (y-coord point))
60 (- (y-coord coord1) (y-coord point)))
61 (*
62 (- (x-coord coord1) (x-coord point))
63 (- (x-coord coord1) (x-coord point)))
64 )
65 )
66 (<= radius2 radius1)))
67
68 ;; A polygon is a vector
69 ;; poly[0] = # of sides
70 ;; poly[1] = # of sides used
71 ;; poly[2] = vector of X coords
72 ;; poly[3] = vector of Y coords
73
74 (defsubst w3-image-poly-nsegs (p)
75 (aref p 0))
76
77 (defsubst w3-image-poly-used-segs (p)
78 (aref p 1))
79
80 (defsubst w3-image-poly-x-coords (p)
81 (aref p 2))
82
83 (defsubst w3-image-poly-y-coords (p)
84 (aref p 3))
85
86 (defsubst w3-image-poly-x-coord (p n)
87 (aref (w3-image-poly-x-coords p) n))
88
89 (defsubst w3-image-poly-y-coord (p n)
90 (aref (w3-image-poly-y-coords p) n))
91
92 (defun w3-image-poly-alloc (n)
93 (if (< n 3)
94 (error "w3-image-poly-alloc: invalid number of sides (%d)" n))
95
96 (vector n 0 (make-vector n nil) (make-vector n nil)))
97
98 (defun w3-image-poly-assign (p x y)
99 (if (>= (w3-image-poly-used-segs p) (w3-image-poly-nsegs p))
100 (error "w3-image-poly-assign: out of space in the w3-image-polygon"))
101 (aset (w3-image-poly-x-coords p) (w3-image-poly-used-segs p) x)
102 (aset (w3-image-poly-y-coords p) (w3-image-poly-used-segs p) y)
103 (aset p 1 (1+ (w3-image-poly-used-segs p))))
104
105 (defun w3-image-ccw (p0 p1 p2)
106 (let (dx1 dx2 dy1 dy2 retval)
107 (setq dx1 (- (x-coord p1) (x-coord p0))
108 dy1 (- (y-coord p1) (y-coord p0))
109 dx2 (- (x-coord p2) (x-coord p0))
110 dy2 (- (y-coord p2) (y-coord p0)))
111 (cond
112 ((> (* dx1 dy2) (* dy1 dx2))
113 (setq retval 1))
114 ((< (* dx1 dy2) (* dy1 dx2))
115 (setq retval -1))
116 ((or (< (* dx1 dx2) 0)
117 (< (* dy1 dy2) 0))
118 (setq retval -1))
119 ((< (+ (* dx1 dx1) (* dy1 dy1))
120 (+ (* dx2 dx2) (* dy2 dy2)))
121 (setq retval 1))
122 (t
123 (setq retval 0)))
124 retval))
125
126 (defun w3-image-line-intersect (l1 l2)
127 (and (<= (* (w3-image-ccw (car l1) (cdr l1) (car l2))
128 (w3-image-ccw (car l1) (cdr l1) (cdr l2))) 0)
129 (<= (* (w3-image-ccw (car l2) (cdr l2) (car l1))
130 (w3-image-ccw (car l2) (cdr l2) (cdr l1))) 0)))
131
132 (defun w3-point-in-poly (point &rest pgon)
133 "Return t iff POINT is within a polygon defined by the list of points PGON.
134 All arguments are either vectors of [X Y] coordinates or lists of such
135 vectors."
136 ;; Right now, this fails on some points that are right on a line segment
137 ;; but it works for everything else (I think)
138 (if (< (length pgon) 3)
139 ;; Malformed polygon!!!
140 nil
141 (let ((p (w3-image-poly-alloc (length pgon)))
142 (hitcount 0)
143 (i 0)
144 (ip1 0)
145 (l1 nil)
146 (l2 (cons (vector (x-coord point) (1+ (y-coord point)))
147 (vector (x-coord point) (y-coord point))))
148 )
149 (while pgon
150 (w3-image-poly-assign p (x-coord (car pgon)) (y-coord (car pgon)))
151 (setq pgon (cdr pgon)))
152 (while (< i (w3-image-poly-nsegs p))
153 ;; Check for wraparound
154 (setq ip1 (1+ i))
155 (if (= ip1 (w3-image-poly-nsegs p))
156 (setq ip1 0))
157
158 (setq l1 (cons (vector (w3-image-poly-x-coord p i)
159 (w3-image-poly-y-coord p i))
160 (vector (w3-image-poly-x-coord p ip1)
161 (w3-image-poly-y-coord p ip1))))
162
163 (if (w3-image-line-intersect l1 l2)
164 (setq hitcount (1+ hitcount)))
165 (setq i (1+ i)))
166 (= 1 (% hitcount 2)))))
167
168 (defun w3-point-in-default (point &rest ignore)
169 t)
170
171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
172
173 (defun w3-point-in-map (point map &optional alt-text)
174 (let (func args done cur default slot)
175 (setq slot (if alt-text 3 2))
176 (while (and map (not done))
177 (setq cur (car map)
178 func (intern-soft (format "w3-point-in-%s" (aref cur 0)))
179 args (aref cur 1)
180 done (and func (fboundp func) (apply func point args))
181 map (cdr map))
182 (if (equal (aref cur 0) "default")
183 (setq default (aref cur slot)
184 done nil)))
185 (cond
186 ((and done (aref cur 2)) ; Found a link
187 (if alt-text
188 (or (aref cur 3) (aref cur 2))
189 (aref cur slot)))
190 (default
191 default)
192 (t nil))))
193
194
195 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
196 ;;; Regular image stuff
197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
198 (defvar w3-allowed-image-types
199 (mapcar (function (lambda (x) (list (car x)))) w3-image-mappings))
200 (defvar w3-image-size-restriction nil)
201
202 (defmacro w3-image-cached-p (href)
203 "Return non-nil iff HREF is in the image cache."
204 (` (cdr-safe (assoc (, href) w3-graphics-list))))
205
206 (defun w3-image-loadable-p (href force)
207 (let ((attribs (url-file-attributes href)))
208 (or force
209 (assoc (nth 8 attribs) w3-allowed-image-types)
210 (null w3-image-size-restriction)
211 (<= (nth 7 attribs) 0)
212 (and (numberp w3-image-size-restriction)
213 (<= (nth 7 attribs) w3-image-size-restriction)))))
214
215 (defmacro w3-image-invalid-glyph-p (glyph)
216 (` (or (null (aref (, glyph) 0))
217 (null (aref (, glyph) 2))
218 (equal (aref (, glyph) 2) ""))))
219
220 ;; data structure in storage is a vector
221 ;; if (href == t) then no action should be taken
222 ;; [ type coordinates href (hopefully)descriptive-text]
223
224
225 (provide 'w3-imap)