X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/93afd0f1d463bec0fc8d3127c1d34ccaa4dbe99b..b93d4f22cbb28c4efbb65fa4927e8b42b41ba00f:/lisp/calc/calc-vec.el diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el index 1980ab7cc0..5b807a5549 100644 --- a/lisp/calc/calc-vec.el +++ b/lisp/calc/calc-vec.el @@ -1,27 +1,25 @@ ;;; calc-vec.el --- vector functions for Calc ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: David Gillespie -;; Maintainer: Jay Belanger +;; Maintainer: Jay Belanger ;; This file is part of GNU Emacs. +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + ;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. Refer to the GNU Emacs General Public -;; License for full details. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; GNU Emacs General Public License. A copy of this license is -;; supposed to have been given to you along with GNU Emacs so you -;; can know your rights and responsibilities. It should be in a -;; file named COPYING. Among other things, the copyright notice -;; and this notice must be preserved on all copies. +;; 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 GNU Emacs. If not, see . ;;; Commentary: @@ -32,6 +30,10 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term)) + + (defun calc-display-strings (n) (interactive "P") (calc-wrapper @@ -449,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") @@ -475,6 +479,11 @@ (calc-wrapper (calc-binary-op "cros" 'calcFunc-cross arg))) +(defun calc-kron (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "kron" 'calcFunc-kron arg))) + (defun calc-remove-duplicates (arg) (interactive "P") (calc-wrapper @@ -1128,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. @@ -1287,18 +1327,24 @@ (defun calcFunc-venum (a) (setq a (calcFunc-vfloor a t)) (or (math-constp a) (math-reject-arg a "*Set must be finite")) - (let ((p a) next) - (while (cdr p) - (setq next (cdr p)) - (if (eq (car-safe (nth 1 p)) 'intv) - (setcdr p (nconc (cdr (calcFunc-index (math-add - (math-sub (nth 3 (nth 1 p)) - (nth 2 (nth 1 p))) - 1) - (nth 2 (nth 1 p)))) - (cdr (cdr p))))) - (setq p next)) - a)) + (let* ((prev a) (this (cdr prev)) this-val next this-last) + (while this + (setq next (cdr this) + this-val (car this)) + (if (eq (car-safe this-val) 'intv) + (progn + (setq this (cdr (calcFunc-index (math-add + (math-sub (nth 3 this-val) + (nth 2 this-val)) + 1) + (nth 2 this-val)))) + (setq this-last (last this)) + (setcdr this-last next) + (setcdr prev this) + (setq prev this-last)) + (setq prev this)) + (setq this next))) + a) (defun calcFunc-vpack (a) (setq a (calcFunc-vfloor a t)) @@ -1325,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) @@ -1462,6 +1509,41 @@ (math-reject-arg a "*Three-vector expected"))) +;;; Compute a Kronecker product +(defun calcFunc-kron (x y &optional nocheck) + "The Kronecker product of objects X and Y. +The objects X and Y may be scalars, vectors or matrices. +The type of the result depends on the types of the operands; +the product of two scalars is a scalar, +of one scalar and a vector is a vector, +of two vectors is a vector. +of one vector and a matrix is a matrix, +of two matrices is a matrix." + (unless nocheck + (cond ((or (math-matrixp x) + (math-matrixp y)) + (unless (math-matrixp x) + (setq x (if (math-vectorp x) + (list 'vec x) + (list 'vec (list 'vec x))))) + (unless (math-matrixp y) + (setq y (if (math-vectorp y) + (list 'vec y) + (list 'vec (list 'vec y)))))) + ((or (math-vectorp x) + (math-vectorp y)) + (unless (math-vectorp x) + (setq x (list 'vec x))) + (unless (math-vectorp y) + (setq y (list 'vec y)))))) + (if (math-vectorp x) + (let (ret) + (dolist (v (cdr x)) + (dolist (w (cdr y)) + (setq ret (cons (calcFunc-kron v w t) ret)))) + (cons 'vec (nreverse ret))) + (math-mul x y))) + ;; The variable math-rb-close is local to math-read-brackets, but ;; is used by math-read-vector, which is called (directly and @@ -1593,5 +1675,5 @@ (provide 'calc-vec) -;;; arch-tag: 7902a7af-ec69-440a-8635-ebb4db263402 +;; arch-tag: 7902a7af-ec69-440a-8635-ebb4db263402 ;;; calc-vec.el ends here