79 lines
1.7 KiB
Common Lisp
79 lines
1.7 KiB
Common Lisp
;;;; decons
|
|
|
|
(defpackage :decons
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:util :scopes/util))
|
|
(:export #:*pi* #:area #:circle
|
|
#:absv #:double #:remainder
|
|
#:scalar-p #:tensor #:at
|
|
#:rapply
|
|
#:line
|
|
))
|
|
|
|
(in-package :decons)
|
|
|
|
;;;; basic explorations
|
|
|
|
(defconstant *pi* 3.14159)
|
|
|
|
(defclass circle ()
|
|
;;; ! implement as closure
|
|
((radius :accessor radius :initarg :radius :initform 1)))
|
|
|
|
(defgeneric area (c)
|
|
(:method ((c circle))
|
|
(* *pi* (radius c) (radius c))))
|
|
|
|
(defun double (f)
|
|
#'(lambda (v) (* 2 (funcall f v))))
|
|
|
|
(defun absv (v)
|
|
(if (< v 0) (- v) v))
|
|
|
|
(defun remainder (v d)
|
|
(if (< v d)
|
|
v
|
|
(remainder (- v d) d)))
|
|
|
|
;;;; library stuff
|
|
|
|
(defgeneric scalar-p (x)
|
|
(:method (x) t)
|
|
(:method ((x list)) nil)
|
|
(:method ((x array)) nil))
|
|
|
|
(defun tensor (s v)
|
|
(make-array s :initial-contents v))
|
|
|
|
(defun at (a &rest subs)
|
|
(apply #'aref a subs))
|
|
|
|
(defun (setf at) (v a &rest subs)
|
|
(setf (apply #'aref a subs) v))
|
|
|
|
(defun traverse (op &rest args)
|
|
(if (null (cdr args))
|
|
(car args)
|
|
(apply #'traverse op (trav2 op (car args) (cadr args)) (cddr args))))
|
|
|
|
(defgeneric trav2 (op a b)
|
|
(:method (op (a number) (b number))
|
|
(funcall op a b)))
|
|
|
|
;;;; rapply and other recursive stuff
|
|
|
|
(defun rapply (op &rest args)
|
|
(if (null (cadr args))
|
|
(rcall op (car args))
|
|
(apply #'rapply (lambda (x) (funcall op (car args) x)) (cdr args))
|
|
))
|
|
|
|
(defgeneric rcall (op arg)
|
|
(:method (op arg) (funcall op arg))
|
|
(:method (op (arg list))
|
|
(mapcar (lambda (x) (rcall op x)) arg)))
|
|
|
|
;;;; parameterized functions
|
|
|
|
(defun line (x)
|
|
#'(lambda (theta) (rapply #'+ (cadr theta) (rapply #'* (car theta) x))))
|