* progmodes/sql.el (sql-mode-sqlite-font-lock-keywords): Added

[bpt/emacs.git] / lisp / calc / calc-vec.el

diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el
index b0220cd..5b807a5 100644 (file)
--- a/lisp/calc/calc-vec.el
+++ b/lisp/calc/calc-vec.el
@@ -1,7 +1,7 @@
 ;;; calc-vec.el --- vector functions for Calc
 
 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
 
 ;; Author: David Gillespie <daveg@synaptics.com>
 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -451,16 +451,18 @@
      (calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1))))))
 
 (defun calc-histogram (n)
-  (interactive "NNumber of bins: ")
+  (interactive "P")
+  (unless (natnump n)
+    (setq n (math-read-expr (read-string "Centers of bins: "))))
   (calc-slow-wrapper
    (if calc-hyperbolic-flag
        (calc-enter-result 2 "hist" (list 'calcFunc-histogram
                                         (calc-top-n 2)
                                         (calc-top-n 1)
-                                        (prefix-numeric-value n)))
+                                        n))
      (calc-enter-result 1 "hist" (list 'calcFunc-histogram
                                       (calc-top-n 1)
-                                      (prefix-numeric-value n))))))
+                                       n)))))
 
 (defun calc-transpose (arg)
   (interactive "P")
@@ -1135,22 +1137,53 @@
   (if (Math-vectorp wts)
       (or (= (length vec) (length wts))
          (math-dimension-error)))
-  (or (natnump n)
-      (math-reject-arg n 'fixnatnump))
-  (let ((res (make-vector n 0))
-       (vp vec)
-       (wvec (Math-vectorp wts))
-       (wp wts)
-       bin)
-    (while (setq vp (cdr vp))
-      (setq bin (car vp))
-      (or (natnump bin)
-         (setq bin (math-floor bin)))
-      (and (natnump bin)
-          (< bin n)
-          (aset res bin (math-add (aref res bin)
-                                  (if wvec (car (setq wp (cdr wp))) wts)))))
-    (cons 'vec (append res nil))))
+  (cond ((natnump n)
+         (let ((res (make-vector n 0))
+               (vp vec)
+               (wvec (Math-vectorp wts))
+               (wp wts)
+               bin)
+           (while (setq vp (cdr vp))
+             (setq bin (car vp))
+             (or (natnump bin)
+                 (setq bin (math-floor bin)))
+            (and (natnump bin)
+                 (< bin n)
+                 (aset res bin 
+                       (math-add (aref res bin)
+                                 (if wvec (car (setq wp (cdr wp))) wts)))))
+           (cons 'vec (append res nil))))
+        ((Math-vectorp n) ;; n is a vector of midpoints
+         (let* ((bds (math-vector-avg n))
+                (res (make-vector (1- (length n)) 0))
+                (vp (cdr vec))
+                (wvec (Math-vectorp wts))
+                (wp wts)
+                num)
+           (while vp
+             (setq num (car vp))
+             (let ((tbds (cdr bds))
+                   (i 0))
+               (while (and tbds (Math-lessp (car tbds) num))
+                 (setq i (1+ i))
+                 (setq tbds (cdr tbds)))
+               (aset res i 
+                     (math-add (aref res i)
+                               (if wvec (car (setq wp (cdr wp))) wts))))
+             (setq vp (cdr vp)))
+           (cons 'vec (append res nil))))
+        (t
+         (math-reject-arg n "*Expecting an integer or vector"))))
+
+;;; Replace a vector [a b c ...] with a vector of averages
+;;; [(a+b)/2 (b+c)/2 ...]
+(defun math-vector-avg (vec)
+  (let ((vp (sort (copy-sequence (cdr vec)) 'math-beforep))
+        (res nil))
+    (while (and vp (cdr vp))
+      (setq res (cons (math-div (math-add (car vp) (cadr vp)) 2) res)
+            vp (cdr vp)))
+    (cons 'vec (reverse res))))
 
 
 ;;; Set operations.
@@ -1338,6 +1371,7 @@
   (if w (setq a (math-clip a w)))
   (if (math-messy-integerp a) (setq a (math-trunc a)))
   (let* ((calc-number-radix 2)
+         (calc-twos-complement-mode nil)
         (neg (math-negp a))
         (aa (if neg (math-sub -1 a) a))
         (str (if (eq aa 0)