cgit.sxemacs.org Git - packages/blob - xemacs-packages/xlib/lisp/xlib-math.el

   1 ;;; xlib-math.el --- icky math things such as 4 byte ints, and int->string stuff.
   2
   3 ;; Copyright (C) 1996, 1997, 1998 Eric M. Ludlam
   4 ;; Copyright (C) 2003-2005 XWEM Org.
   5 ;;
   6 ;; Author: Eric M. Ludlam <zappo@gnu.ai.mit.edu>
   7 ;; Modified: Zajcev Evgeny <zevlg@yandex.ru>
   8 ;; Keywords: xlib, xwem
   9 ;; X-RCS: $Id: xlib-math.el,v 1.8 2005-04-04 19:55:28 lg Exp $
  10
  11 ;; This file is part of XWEM.
  12
  13 ;; XWEM is free software; you can redistribute it and/or modify it
  14 ;; 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 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  20 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  21 ;; License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  26 ;; 02111-1307, USA.
  27
  28 ;;; Synched up with: Not in FSF
  29
  30 ;;; Commentary:
  31 ;;  numbers->string string->numbers
  32 ;;
  33 ;; These routines are needed to convert numbers into strings which
  34 ;; are passed over the network.
  35 ;;
  36
  37 ;;; Code:
  38 \f
  39
  40 (defmacro Xtruncate (val)
  41   "Do a safe truncate of VAL that might be larger than MAXINT."
  42   `(truncate (if ,val (mod ,val 65536) 0)))
  43
  44 (defmacro XCharacter (val)
  45   "Convert VAL (a float) into a truncated character value."
  46   (if (fboundp 'int-to-char)
  47       (list 'int-to-char
  48             (list 'logand (list 'truncate (list 'mod val 65536)) 255))
  49     (if (>= emacs-major-version 20)
  50         (list 'logand (list 'truncate (list 'mod val 65536)) 255)
  51       (list 'truncate (list 'mod val 65536)))))
  52
  53 (defmacro Xforcenum (val)
  54   "Force VAL (a character) to be a number.
  55 This macro forces XEmacs 20.3 to behave."
  56   (if (fboundp 'char-to-int)
  57       `(char-to-int ,val)
  58     val))
  59
  60 (defsubst int->string1 (num)
  61   "Convert NUM into a 1 byte string in network order and return."
  62   (char-to-string (XCharacter num)))
  63
  64 (defsubst string1->int (string)
  65   "Convert STRING characters into an integer and return."
  66   (string->int string))
  67
  68 (defun int->string (num)
  69   "Convert NUM into a 2 byte string in network order and return."
  70   (setq num (truncate num))
  71   (let ((l (logand num 255))    ;top byte
  72         (h (ash (mod num 65536) -8))) ;upper byte
  73     (concat (char-to-string l) (char-to-string h))))
  74
  75 (defalias 'int->string2 'int->string)
  76
  77 (defun string->int (string)
  78   "Convert STRING 1st two characters into an integer and return."
  79   (let ((l (aref string 0))
  80         (h (if (> (length string) 1) (aref string 1) 0)))
  81     (+ l (ash h 8))))
  82
  83 (defun int->string4 (num)
  84   "Convert NUM (a float or int) into a 4 byte network order string."
  85   (if (integerp num)
  86       ;; if it isn't a float, then do int things
  87       (concat (int->string num) (int->string 0)) ;0 upper part
  88 ;    (if (> 0 num)
  89 ;       (error "4 byte number is negative during conversion."))
  90     (let ((tmp (float num))
  91           (ts nil))
  92       ;; We only need to truncate the first part.  After the first
  93       ;; 8 bit shift, the number is small enought that a regular
  94       ;; truncate is safe.
  95       (setq ts (concat ts (char-to-string (XCharacter tmp))))
  96       (setq tmp (/ tmp (float 256)))
  97       (setq ts (concat ts (char-to-string (XCharacter tmp))))
  98       (setq tmp (/ tmp (float 256)))
  99       (setq ts (concat ts (char-to-string (XCharacter tmp))))
 100       (setq tmp (/ tmp (float 256)))
 101       (setq ts (concat ts (char-to-string (XCharacter tmp)))))))
 102
 103 (defun string4->int (string)
 104   "Convert STRING 1st four characters into a float and return."
 105   ;; do nothing yet until we know what we need to do.
 106   (+ (float (Xforcenum (aref string 0)))
 107      (* (float (Xforcenum (aref string 1))) 256)
 108      (* (float (Xforcenum (aref string 2))) 256 256)
 109      (* (float (Xforcenum (aref string 3))) 256 256 256)))
 110
 111 (defun string2->number (string)
 112   "Convert 2 first bytes in STRING to number."
 113   (string->int string))
 114
 115 (defun string4->number (string)
 116   "Convert 4 first bytes in STRING to number.
 117 NOTE: Use `string4->int' when overflow may occur."
 118   (+ (Xforcenum (aref string 0))
 119      (lsh (Xforcenum (aref string 1)) 8)
 120      (lsh (Xforcenum (aref string 2)) 16)
 121      (lsh (Xforcenum (aref string 3)) 24)))
 122
 123 (defun int->string3 (num)
 124   "Convert 3 first bytes in STRING to integer."
 125   (string (logand num 255)
 126           (logand (lsh num -8) 255)
 127           (logand (lsh num -16) 255)))
 128
 129 ;;; Converters
 130 (defun string->card8 (str)
 131   (Xforcenum (aref str 0)))
 132
 133 (defun string->card16 (str)
 134   (+ (Xforcenum (aref str 0))
 135      (lsh (Xforcenum (aref str 1)) 8)))
 136
 137 (defun string->card32 (str)
 138   (+ (Xforcenum (aref str 0))
 139      (lsh (Xforcenum (aref str 1)) 8)
 140      (lsh (Xforcenum (aref str 2)) 16)
 141      (lsh (Xforcenum (aref str 3)) 24)))
 142
 143 (defun string->int8 (str)
 144   (let ((v (Xforcenum (aref str 0))))
 145     (funcall (if (> v #x7f) '- '+) (logand v #x7f))))
 146
 147 (defun string->int16 (str)
 148   (let ((v (Xforcenum (aref str 1))))
 149     (funcall (if (> v #x7f) '- '+)
 150              (+ (Xforcenum (aref str 0))
 151                 (lsh (logand v #x7f) 8)))))
 152
 153 (defun string->int32 (str)
 154   (let ((v (Xforcenum (aref str 3))))
 155     (funcall (if (> v #x7f) '- '+)
 156              (+ (Xforcenum (aref str 0))
 157                 (lsh (Xforcenum (aref str 1)) 8)
 158                 (lsh (Xforcenum (aref str 2)) 16)
 159                 (lsh (logand v #x7f) 24)))))
 160
 161 ;;; Back coverters
 162 ;; TODO: - write
 163 (defun card8->string (card8)
 164   )
 165
 166 (defun card16->string (card16)
 167   )
 168
 169 (defun card32->string (card32)
 170   )
 171
 172 (defun int8->string (int8)
 173   )
 174
 175 (defun int16->string (int16)
 176   )
 177
 178 (defun int32->string (int32)
 179   )
 180
 181 (defun X-pad (number)
 182   "Return a number which is the padding for an X message of length NUMBER."
 183   (% (- 4 (% number 4)) 4))
 184
 185 (defun X-padlen (string)
 186   "Return a number which is length of STRING / 4.
 187 If string is not divisible by 4, return string/4 + 1"
 188   (if (= (% (length string) 4) 0)
 189       (/ (length string) 4)
 190     (+ (/ (length string) 4) 1)))
 191
 192 ;;; MASK routines:
 193 ;;
 194 ;; These routines are needed to handle the 4 byte masks used in X.
 195 ;; We won't implement the whole set, just the functionality we need
 196 ;; to make the checks we want.
 197 ;;
 198 (defun Xmask (pos)
 199   "Create a mask with a bit set in position POS.
 200 This routine will not work for position 32 and up because we sim
 201 4 bytes of info"
 202   (if (< pos 16)
 203       (float (lsh 1 pos))               ;put in first byte
 204     (setq pos (- pos  16))              ;divide pos by 16
 205     (* (float (lsh 1 pos)) (float 65536)) ;push into high byte
 206     ))
 207
 208 (defun Xmask-and (val &rest args)
 209   "Logically `and' VAL and MASK together.
 210 They are floats to be broken down into two two byte ints.
 211 MASK is stored in ARGS which is a list of *fill in when I remember*"
 212   (while args
 213     (let ((mask (car args)))
 214       (setq args (cdr args))
 215       (let ((lv (logand (Xtruncate val) 65535))
 216             (hv (Xtruncate (/ val (float 65536))))
 217             (lm (logand (Xtruncate mask) 65535))
 218             (hm (Xtruncate (/ mask (float 65536)))))
 219         (setq val (+ (float (logand lv lm))
 220                      (* (float (logand hv hm)) 65536))))))
 221   val)
 222
 223 (defun Xmask-or (val &rest args)
 224   "Logically or VAL and MASK together.
 225 They are floats to be broken down into two two byte ints.
 226 MASK is stored in ARGS which is a list of *fill in when I remember*"
 227   (while args
 228     (let ((mask (car args)))
 229       (setq args (cdr args))
 230       (let ((lv (logand (Xtruncate val) 65535))
 231             (hv (Xtruncate (/ val (float 65536))))
 232             (lm (logand (Xtruncate mask) 65535))
 233             (hm (Xtruncate (/ mask (float 65536)))))
 234         (setq val (+ (float (logior lv lm))
 235                      (* (float (logior hv hm)) 65536))))))
 236   val)
 237
 238 (defun Xtest (val flag)
 239   "Test value of bytes VAL for presence of FLAG.
 240 Return t if it exists, nil otherwise."
 241   (if (= (Xmask-and val flag) 0) nil t))
 242
 243 ;;; BITWISE routines:
 244 ;;
 245 ;; These routines are used to do other things to bits, necessary for
 246 ;; calculating out new resource IDs for objects.
 247 ;;
 248
 249 (defun Xcount-bits-int (mask)
 250   "Count the number of bits in a given integer (16 bit) MASK."
 251   (let ((ret 0))
 252     (while (/= mask 0)
 253       (if (Xtest mask 1) (setq ret (1+ ret)))
 254       (setq mask (ash mask -1)))
 255     ret))
 256
 257 (defun Xmask-count (mask)
 258   "Count the number of bits set in the mask MASK.
 259 This is needed to identify new objects (client-selectable) thingies."
 260   (let ((lv (Xtruncate mask))
 261         (hv (Xtruncate (/ mask (float 65536)))))
 262     (+ (Xcount-bits-int lv) (Xcount-bits-int hv))))
 263
 264 (defun Xmask-int-string (mask)
 265   "Convert MASK as an integer into a string of 0s and 1s."
 266   (let ((cnt 15)
 267         (s nil))
 268     (while (/= cnt -1)
 269       (setq s (concat s (if (= (logand mask (lsh 1 cnt)) 0) "0" "1")))
 270       (setq cnt (1- cnt)))
 271     s))
 272
 273 (defun Xmask-string (mask)
 274   "Convert MASK into a string of 0s and 1s."
 275   (let ((lv (Xtruncate mask))
 276         (hv (Xtruncate (/ mask (float 65536)))))
 277     (concat (Xmask-int-string hv) (Xmask-int-string lv))))
 278
 279 (defun Xmask-int-hex-string (mask &optional fill)
 280   "Convert the integer MASK into a full hexidecimal number.
 281 Optional argument FILL means to add 0s as necessary."
 282   (let ((s (format "%x" mask)))
 283     (if fill (substring (concat "0000" s) (length s)) s)))
 284
 285 (defun Xmask-hex-string (mask)
 286   "Convert MASK into a hexidecimal string."
 287   (let ((lv (Xtruncate mask))
 288         (hv (Xtruncate (/ mask (float 65536)))))
 289     (concat "0x"
 290             (Xmask-int-hex-string hv)
 291             (Xmask-int-hex-string lv (/= hv 0)))))
 292
 293 \f
 294 (provide 'xlib-math)
 295
 296 ;;; xmath.el ends here