cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/w3-imap.el

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