118 lines
2.7 KiB
Common Lisp
118 lines
2.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 #:rreduce
|
|
#:combine #:cost
|
|
#:line
|
|
#:lgx
|
|
))
|
|
|
|
(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)))
|
|
|
|
;;;; tensor 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, rreduce - recursive application of operations
|
|
|
|
(defun rapply (op arg1 &optional arg2)
|
|
(if arg2
|
|
(rcall (rcurry op arg1) arg2)
|
|
(rcall op arg1)))
|
|
|
|
(defgeneric rcall (op arg)
|
|
(:method (op arg) (funcall op arg))
|
|
(:method (op (arg list))
|
|
(mapcar (lambda (i) (rcall op i)) arg)))
|
|
|
|
(defgeneric rcurry (op arg)
|
|
(:method (op arg) (lambda (j) (funcall op arg j)))
|
|
(:method (op (arg list))
|
|
(lambda (j) (mapcar (lambda (i) (rapply op i j)) arg))))
|
|
|
|
(defun rreduce (op arg &key (initial-value 0))
|
|
(reduce op arg :initial-value initial-value
|
|
:key (lambda (v) (relement op v :initial-value initial-value))))
|
|
|
|
(defgeneric relement (op v &key initial-value)
|
|
(:method (op v &key (initial-value 0)) v)
|
|
(:method (op (v list) &key (initial-value 0))
|
|
(rreduce op v :initial-value initial-value)))
|
|
|
|
;;;; combine
|
|
|
|
(defun combine (l1 l2)
|
|
(mapcar (lambda (x) (scons (pop l1) x)) l2))
|
|
|
|
(defgeneric scons (a b)
|
|
(:method (a b) (list a b))
|
|
(:method (a (b list)) (cons a b)))
|
|
|
|
;;;; cost calculation
|
|
|
|
(defun cost (have want)
|
|
(reduce #'+
|
|
(mapcar (lambda (p) (abs (apply #'- p)))
|
|
(combine have want))))
|
|
|
|
;;;; logging (printing) functions for debugging purposes
|
|
|
|
(defun lgx (op)
|
|
(lambda (&rest args)
|
|
(let ((r (apply op args)))
|
|
(format t "~&(~a ~a) = ~a~%" op args r)
|
|
r)))
|
|
|
|
;;;; parameterized functions
|
|
|
|
(defun line (x)
|
|
#'(lambda (theta) (rapply #'+ (cadr theta) (rapply #'* (car theta) x))))
|