;;; xlib-math.el --- icky math things such as 4 byte ints, and int->string stuff.

;; Copyright (C) 1996, 1997, 1998 Eric M. Ludlam
;; Copyright (C) 2003-2005 XWEM Org.
;;
;; Author: Eric M. Ludlam <zappo@gnu.ai.mit.edu>
;; Modified: Zajcev Evgeny <zevlg@yandex.ru>
;; Keywords: xlib, xwem
;; X-RCS: $Id: xlib-math.el,v 1.8 2005-04-04 19:55:28 lg Exp $

;; This file is part of XWEM.

;; XWEM is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XWEM is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
;; License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:
;;  numbers->string string->numbers
;;
;; These routines are needed to convert numbers into strings which
;; are passed over the network.
;;

;;; Code:


(defmacro Xtruncate (val)
  "Do a safe truncate of VAL that might be larger than MAXINT."
  `(truncate (if ,val (mod ,val 65536) 0)))

(defmacro XCharacter (val)
  "Convert VAL (a float) into a truncated character value."
  (if (fboundp 'int-to-char)
      (list 'int-to-char
	    (list 'logand (list 'truncate (list 'mod val 65536)) 255))
    (if (>= emacs-major-version 20)
	(list 'logand (list 'truncate (list 'mod val 65536)) 255)
      (list 'truncate (list 'mod val 65536)))))

(defmacro Xforcenum (val)
  "Force VAL (a character) to be a number.
This macro forces XEmacs 20.3 to behave."
  (if (fboundp 'char-to-int)
      `(char-to-int ,val)
    val))

(defsubst int->string1 (num)
  "Convert NUM into a 1 byte string in network order and return."
  (char-to-string (XCharacter num)))

(defsubst string1->int (string)
  "Convert STRING characters into an integer and return."
  (string->int string))

(defun int->string (num)
  "Convert NUM into a 2 byte string in network order and return."
  (setq num (truncate num))
  (let ((l (logand num 255))	;top byte
	(h (ash (mod num 65536) -8))) ;upper byte
    (concat (char-to-string l) (char-to-string h))))

(defalias 'int->string2 'int->string)

(defun string->int (string)
  "Convert STRING 1st two characters into an integer and return."
  (let ((l (aref string 0))
	(h (if (> (length string) 1) (aref string 1) 0)))
    (+ l (ash h 8))))

(defun int->string4 (num)
  "Convert NUM (a float or int) into a 4 byte network order string."
  (if (integerp num)
      ;; if it isn't a float, then do int things
      (concat (int->string num) (int->string 0)) ;0 upper part
;    (if (> 0 num)
;	(error "4 byte number is negative during conversion."))
    (let ((tmp (float num))
	  (ts nil))
      ;; We only need to truncate the first part.  After the first
      ;; 8 bit shift, the number is small enought that a regular
      ;; truncate is safe.
      (setq ts (concat ts (char-to-string (XCharacter tmp))))
      (setq tmp (/ tmp (float 256)))
      (setq ts (concat ts (char-to-string (XCharacter tmp))))
      (setq tmp (/ tmp (float 256)))
      (setq ts (concat ts (char-to-string (XCharacter tmp))))
      (setq tmp (/ tmp (float 256)))
      (setq ts (concat ts (char-to-string (XCharacter tmp)))))))

(defun string4->int (string)
  "Convert STRING 1st four characters into a float and return."
  ;; do nothing yet until we know what we need to do.
  (+ (float (Xforcenum (aref string 0)))
     (* (float (Xforcenum (aref string 1))) 256)
     (* (float (Xforcenum (aref string 2))) 256 256)
     (* (float (Xforcenum (aref string 3))) 256 256 256)))

(defun string2->number (string)
  "Convert 2 first bytes in STRING to number."
  (string->int string))

(defun string4->number (string)
  "Convert 4 first bytes in STRING to number.
NOTE: Use `string4->int' when overflow may occur."
  (+ (Xforcenum (aref string 0))
     (lsh (Xforcenum (aref string 1)) 8)
     (lsh (Xforcenum (aref string 2)) 16)
     (lsh (Xforcenum (aref string 3)) 24)))

(defun int->string3 (num)
  "Convert 3 first bytes in STRING to integer."
  (string (logand num 255)
	  (logand (lsh num -8) 255)
	  (logand (lsh num -16) 255)))

;;; Converters
(defun string->card8 (str)
  (Xforcenum (aref str 0)))

(defun string->card16 (str)
  (+ (Xforcenum (aref str 0))
     (lsh (Xforcenum (aref str 1)) 8)))

(defun string->card32 (str)
  (+ (Xforcenum (aref str 0))
     (lsh (Xforcenum (aref str 1)) 8)
     (lsh (Xforcenum (aref str 2)) 16)
     (lsh (Xforcenum (aref str 3)) 24)))
  
(defun string->int8 (str)
  (let ((v (Xforcenum (aref str 0))))
    (funcall (if (> v #x7f) '- '+) (logand v #x7f))))

(defun string->int16 (str)
  (let ((v (Xforcenum (aref str 1))))
    (funcall (if (> v #x7f) '- '+)
             (+ (Xforcenum (aref str 0))
                (lsh (logand v #x7f) 8)))))

(defun string->int32 (str)
  (let ((v (Xforcenum (aref str 3))))
    (funcall (if (> v #x7f) '- '+)
             (+ (Xforcenum (aref str 0))
                (lsh (Xforcenum (aref str 1)) 8)
                (lsh (Xforcenum (aref str 2)) 16)
                (lsh (logand v #x7f) 24)))))

;;; Back coverters
;; TODO: - write
(defun card8->string (card8)
  )

(defun card16->string (card16)
  )

(defun card32->string (card32)
  )

(defun int8->string (int8)
  )

(defun int16->string (int16)
  )

(defun int32->string (int32)
  )

(defun X-pad (number)
  "Return a number which is the padding for an X message of length NUMBER."
  (% (- 4 (% number 4)) 4))

(defun X-padlen (string)
  "Return a number which is length of STRING / 4.
If string is not divisible by 4, return string/4 + 1"
  (if (= (% (length string) 4) 0)
      (/ (length string) 4)
    (+ (/ (length string) 4) 1)))

;;; MASK routines:
;;
;; These routines are needed to handle the 4 byte masks used in X.
;; We won't implement the whole set, just the functionality we need
;; to make the checks we want.
;;
(defun Xmask (pos)
  "Create a mask with a bit set in position POS.
This routine will not work for position 32 and up because we sim
4 bytes of info"
  (if (< pos 16)
      (float (lsh 1 pos))		;put in first byte
    (setq pos (- pos  16))		;divide pos by 16
    (* (float (lsh 1 pos)) (float 65536)) ;push into high byte
    ))

(defun Xmask-and (val &rest args)
  "Logically `and' VAL and MASK together.
They are floats to be broken down into two two byte ints.
MASK is stored in ARGS which is a list of *fill in when I remember*"
  (while args
    (let ((mask (car args)))
      (setq args (cdr args))
      (let ((lv (logand (Xtruncate val) 65535))
	    (hv (Xtruncate (/ val (float 65536))))
	    (lm (logand (Xtruncate mask) 65535))
	    (hm (Xtruncate (/ mask (float 65536)))))
	(setq val (+ (float (logand lv lm))
		     (* (float (logand hv hm)) 65536))))))
  val)

(defun Xmask-or (val &rest args)
  "Logically or VAL and MASK together.
They are floats to be broken down into two two byte ints.
MASK is stored in ARGS which is a list of *fill in when I remember*"
  (while args
    (let ((mask (car args)))
      (setq args (cdr args))
      (let ((lv (logand (Xtruncate val) 65535))
	    (hv (Xtruncate (/ val (float 65536))))
	    (lm (logand (Xtruncate mask) 65535))
	    (hm (Xtruncate (/ mask (float 65536)))))
	(setq val (+ (float (logior lv lm))
		     (* (float (logior hv hm)) 65536))))))
  val)

(defun Xtest (val flag)
  "Test value of bytes VAL for presence of FLAG.
Return t if it exists, nil otherwise."
  (if (= (Xmask-and val flag) 0) nil t))

;;; BITWISE routines:
;;
;; These routines are used to do other things to bits, necessary for
;; calculating out new resource IDs for objects.
;;

(defun Xcount-bits-int (mask)
  "Count the number of bits in a given integer (16 bit) MASK."
  (let ((ret 0))
    (while (/= mask 0)
      (if (Xtest mask 1) (setq ret (1+ ret)))
      (setq mask (ash mask -1)))
    ret))

(defun Xmask-count (mask)
  "Count the number of bits set in the mask MASK.
This is needed to identify new objects (client-selectable) thingies."
  (let ((lv (Xtruncate mask))
	(hv (Xtruncate (/ mask (float 65536)))))
    (+ (Xcount-bits-int lv) (Xcount-bits-int hv))))

(defun Xmask-int-string (mask)
  "Convert MASK as an integer into a string of 0s and 1s."
  (let ((cnt 15)
	(s nil))
    (while (/= cnt -1)
      (setq s (concat s (if (= (logand mask (lsh 1 cnt)) 0) "0" "1")))
      (setq cnt (1- cnt)))
    s))

(defun Xmask-string (mask)
  "Convert MASK into a string of 0s and 1s."
  (let ((lv (Xtruncate mask))
	(hv (Xtruncate (/ mask (float 65536)))))
    (concat (Xmask-int-string hv) (Xmask-int-string lv))))

(defun Xmask-int-hex-string (mask &optional fill)
  "Convert the integer MASK into a full hexidecimal number.
Optional argument FILL means to add 0s as necessary."
  (let ((s (format "%x" mask)))
    (if fill (substring (concat "0000" s) (length s)) s)))

(defun Xmask-hex-string (mask)
  "Convert MASK into a hexidecimal string."
  (let ((lv (Xtruncate mask))
	(hv (Xtruncate (/ mask (float 65536)))))
    (concat "0x"
	    (Xmask-int-hex-string hv)
	    (Xmask-int-hex-string lv (/= hv 0)))))


(provide 'xlib-math)

;;; xmath.el ends here