cco/decons
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

move functionality to new files / packages recurse and mlx

Browse source
This commit is contained in:
Helmut Merz 2025-05-31 11:48:52 +02:00
parent f08545db8e
commit a70a1487eb
5 changed files with 151 additions and 158 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
decons.asd
View file

@ -7,8 +7,9 @@
:homepage "https://www.cyberconcepts.org"
:description "Deconstruction as a method for implementing machine intelligence."
:depends-on (:alexandria
:scopes :scopes/test)
:components ((:file "decons")
:scopes-core :scopes/test)
:components ((:file "mlx" :depends-on ("recurse"))
(:file "recurse")
(:file "xplore"))
:long-description "decons: The base system of the decons project."
:in-order-to ((test-op (test-op "decons/test"))))

135
decons.lisp
View file

@ -1,135 +0,0 @@
;;;; decons
(defpackage :decons
(:use :common-lisp)
(:local-nicknames (:shape :scopes/shape)
(:util :scopes/util))
(:export #:rapply #:rreduce #:rreduce-1 #:radd #:rmul #:rsub #:rdiv #:rsqr
#:default-deviation #:l2-loss
*revisions* *alpha* #:gradient-descent
#:nabla-xp
#:line #:quad
#:*obj*))
(in-package :decons)
;;;; common (basic) stuff
(defun sqr (x) (* x x))
(defun sum (data) (reduce #'+ data))
;;;; rapply, rreduce - recursive application of operations
(defun rapply (op arg1 &optional arg2)
(if arg2
;(rcall (rcurry op arg1) arg2)
(rcall2 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 rcall2 (op a1 a2)
(:method (op a1 a2) (funcall op a1 a2))
(:method (op (a1 list) a2)
(mapcar (lambda (i) (rcall2 op i a2)) a1))
(:method (op a1 (a2 list))
(mapcar (lambda (j) (rcall2 op a1 j)) a2))
(:method (op (a1 list) (a2 list))
(mapcar (lambda (i j) (rcall2 op i j)) a1 a2)))
(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)))
(defgeneric rreduce-1 (op arg &key initial-value)
(:method (op arg &key (initial-value 0)) arg)
(:method (op (arg list) &key (initial-value 0))
(if (some #'consp arg)
(mapcar (lambda (x) (rreduce-1 op x :initial-value initial-value)) arg)
(reduce op arg :initial-value initial-value))))
(defun radd (a b) (rapply #'+ a b))
(defun rmul (a b) (rapply #'* a b))
(defun rsub (a b) (rapply #'- a b))
(defun rdiv (a b) (rapply #'/ a b))
(defun rsqr (a) (rapply #'sqr a))
;;;; loss calculation, collect trial data (parameters, resulting loss)
(defun default-deviation (observed calculated &key (norm #'sqr))
(sum (mapcar (lambda (a b) (funcall norm (- a b)))
observed calculated)))
(defun l2-loss (target &key (deviation #'default-deviation))
(lambda (dataset) ; expectant function
(lambda (theta) ; objective function
(let* ((objective (funcall target (car dataset)))
(calculated (funcall objective theta)))
(funcall deviation (cadr dataset) calculated)))))
;;;; optimization by revision (= gradient descent)
(defparameter *revisions* 1000)
(defparameter *alpha* 0.01)
(defun gradient-descent (obj theta)
(flet ((try-theta (th)
(mapcar (lambda (p g) (- p (* *alpha* g)))
th (nabla-xp obj th))))
(dotimes (ix *revisions*)
(setf theta (try-theta theta)))
theta))
;;;; experimental differentiation
(defvar *diff-variation* 0.01)
(defun nabla-xp (fn args)
"Determine gradients by experiment: vary args and record changes."
(let ((base (funcall fn args))
(vargs (apply #'vector args))
(res nil))
(dotimes (ix (length vargs))
(push (diff fn vargs ix base) res))
(reverse res)))
(defun diff (fn vargs ix base)
(let* ((vdiff *diff-variation*)
(val (svref vargs ix))
(argsx (copy-seq vargs)) r+ r-)
(setf (svref argsx ix) (+ val vdiff))
(setf r+ (/ (- (funcall fn (map 'list #'identity argsx)) base) vdiff))
(setf (svref argsx ix) (- val vdiff))
(setf r- (/ (- base (funcall fn (map 'list #'identity argsx))) vdiff))
;(util:lgi base r+ r-)
(/ (+ r+ r-) 2)))
;;;; parameterized target functions
(defun line (x)
(lambda (theta)
(radd (rmul (first theta) x) (second theta))))
(defun quad (x)
(lambda (theta)
(radd (rmul (first theta) (rsqr x))
(radd (rmul (second theta) x)
(third theta)))))
;;;; working area
(defvar *obj* nil)

79
mlx.lisp Normal file
View file

@ -0,0 +1,79 @@
;;;; decons/mlx - machine learning experiments
(defpackage :decons/mlx
(:use :common-lisp)
(:local-nicknames (:r :decons/recurse)
(:util :scopes/util))
(:export #:default-deviation #:l2-loss
*revisions* *alpha* #:gradient-descent
#:nabla-xp
#:line #:quad
#:*obj*))
(in-package :decons/mlx)
;;;; loss calculation
(defun default-deviation (observed calculated &key (norm (lambda (x) (* x x))))
(reduce #'+ (mapcar (lambda (a b) (funcall norm (- a b)))
observed calculated)))
(defun l2-loss (target &key (deviation #'default-deviation))
(lambda (dataset) ; expectant function
(lambda (theta) ; objective function
(let* ((objective (funcall target (car dataset)))
(calculated (funcall objective theta)))
(funcall deviation (cadr dataset) calculated)))))
;;;; optimization by revision (= gradient descent)
(defparameter *revisions* 1000)
(defparameter *alpha* 0.01)
(defun gradient-descent (obj theta)
(flet ((try-theta (th)
(mapcar (lambda (p g) (- p (* *alpha* g)))
th (nabla-xp obj th))))
(dotimes (ix *revisions*)
(setf theta (try-theta theta)))
theta))
;;;; experimental differentiation
(defvar *diff-variation* 0.01)
(defun nabla-xp (fn args)
"Determine gradients by experiment: vary args and record changing results."
(let ((base (funcall fn args))
(vargs (apply #'vector args))
(res nil))
(dotimes (ix (length vargs))
(push (diff fn vargs ix base) res))
(reverse res)))
(defun diff (fn vargs ix base)
(let* ((vdiff *diff-variation*)
(val (svref vargs ix))
(argsx (copy-seq vargs)) r+ r-)
(setf (svref argsx ix) (+ val vdiff))
(setf r+ (/ (- (funcall fn (map 'list #'identity argsx)) base) vdiff))
(setf (svref argsx ix) (- val vdiff))
(setf r- (/ (- base (funcall fn (map 'list #'identity argsx))) vdiff))
;(util:lgi base r+ r-)
(/ (+ r+ r-) 2)))
;;;; parameterized target functions
(defun line (x)
(lambda (theta)
(r:add (r:mul (first theta) x) (second theta))))
(defun quad (x)
(lambda (theta)
(r:add (r:mul (first theta) (r:sqr x))
(r:add (r:mul (second theta) x)
(third theta)))))
;;;; working area
(defvar *obj* nil)

46
recurse.lisp Normal file
View file

@ -0,0 +1,46 @@
;;;; decons/recurse - recursive calculations
(defpackage :decons/recurse
(:use :common-lisp)
(:local-nicknames (:util :scopes/util))
(:export #:call #:call2 #:reduce-all #:reduce-1 #:add #:mul #:sub #:div #:sqr))
(in-package :decons/recurse)
;;;; recursive application of operations
(defgeneric call (op arg)
(:method (op arg) (funcall op arg))
(:method (op (arg list))
(mapcar (lambda (i) (call op i)) arg)))
(defgeneric call2 (op a1 a2)
(:method (op a1 a2) (funcall op a1 a2))
(:method (op (a1 list) a2)
(mapcar (lambda (i) (call2 op i a2)) a1))
(:method (op a1 (a2 list))
(mapcar (lambda (j) (call2 op a1 j)) a2))
(:method (op (a1 list) (a2 list))
(mapcar (lambda (i j) (call2 op i j)) a1 a2)))
(defun reduce-all (op arg &key (initial-value 0))
(reduce op arg :initial-value initial-value
:key (lambda (v) (element op v :initial-value initial-value))))
(defgeneric element (op v &key initial-value)
(:method (op v &key (initial-value 0)) v)
(:method (op (v list) &key (initial-value 0))
(reduce-all op v :initial-value initial-value)))
(defgeneric reduce-1 (op arg &key initial-value)
(:method (op arg &key (initial-value 0)) arg)
(:method (op (arg list) &key (initial-value 0))
(if (some #'consp arg)
(mapcar (lambda (x) (reduce-1 op x :initial-value initial-value)) arg)
(reduce op arg :initial-value initial-value))))
(defun add (a b) (call2 #'+ a b))
(defun mul (a b) (call2 #'* a b))
(defun sub (a b) (call2 #'- a b))
(defun div (a b) (call2 #'/ a b))
(defun sqr (a) (call (lambda (x) (* x x)) a))

44
test-decons.lisp
View file

@ -2,7 +2,9 @@
(defpackage :test-decons
(:use :common-lisp)
(:local-nicknames (:xplore :decons/xplore)
(:local-nicknames (:mlx :decons/mlx)
(:r :decons/recurse)
(:xplore :decons/xplore)
(:t :scopes/testing))
(:export #:run)
(:import-from :scopes/testing #:deftest #:== #:!=))
@ -13,7 +15,7 @@
(let ((t:*test-suite* (t:test-suite "decons")))
(test-basic)
(test-tensor)
(test-rapply)
(test-rcall)
(test-rreduce)
(test-line)
(test-quad)
@ -39,40 +41,40 @@
(== (xplore:scalar-p t1) nil)
))
(deftest test-rapply ()
(== (decons:rapply #'1+ 7) 8)
(== (decons:rapply #'1+ '(2 3)) '(3 4))
(== (decons:radd 2 3) 5)
(== (decons:radd 3 '(4 5)) '(7 8))
(== (decons:radd '(2 3) '(4 5)) '(6 8)) ; not '((6 7) (7 8))
(== (decons:rsub '(6 7) '(4 5)) '(2 2)) ; not '((2 3) (1 2))
(== (decons:rsqr '(2 3 4)) '(4 9 16))
(deftest test-rcall ()
(== (r:call #'1+ 7) 8)
(== (r:call #'1+ '(2 3)) '(3 4))
(== (r:add 2 3) 5)
(== (r:add 3 '(4 5)) '(7 8))
(== (r:add '(2 3) '(4 5)) '(6 8)) ; not '((6 7) (7 8))
(== (r:sub '(6 7) '(4 5)) '(2 2)) ; not '((2 3) (1 2))
(== (r:sqr '(2 3 4)) '(4 9 16))
)
(deftest test-rreduce ()
(== (decons:rreduce #'+ '(1 2 (3 4))) 10)
(== (decons:rreduce-1 #'+ '(1 2 (3 4))) '(1 2 7))
(== (r:reduce-all #'+ '(1 2 (3 4))) 10)
(== (r:reduce-1 #'+ '(1 2 (3 4))) '(1 2 7))
)
(defvar *ds1* '((2.0 1.0 4.0 3.0)
(1.8 1.2 4.2 3.3)))
(deftest test-line ()
(let ((p1 (decons:line 0.0))
(p2 (decons:line 1.0))
(let ((p1 (mlx:line 0.0))
(p2 (mlx:line 1.0))
ps1 objective)
(== (funcall p1 '(0.5 2.0)) 2.0)
(== (funcall p2 '(0.5 2.0)) 2.5)
(setf ps1 (decons:line (car *ds1*)))
(setf ps1 (mlx:line (car *ds1*)))
(== (funcall ps1 '(0.5 2.0)) '(3.0 2.5 4.0 3.5))
(== (funcall ps1 '(1.0 0.0)) '(2.0 1.0 4.0 3.0))
(== (decons:default-deviation (cadr *ds1*) (funcall ps1 '(1.0 0.0)))
(== (mlx:default-deviation (cadr *ds1*) (funcall ps1 '(1.0 0.0)))
0.20999993) ;0.899999861)
(setf objective (funcall (decons:l2-loss #'decons:line) *ds1*))
(setf decons:*obj* objective) ; for interactive experiments
(setf objective (funcall (mlx:l2-loss #'mlx:line) *ds1*))
(setf mlx:*obj* objective) ; for interactive experiments
(== (funcall objective '(0.0 0.0)) 33.21)
(== (decons:nabla-xp objective '(0.0 0.0)) '(-62.999725 -21.0001))
(== (decons:gradient-descent objective '(0.0 0.0)) '(1.0499986 3.6358833e-6))
(== (mlx:nabla-xp objective '(0.0 0.0)) '(-62.999725 -21.0001))
(== (mlx:gradient-descent objective '(0.0 0.0)) '(1.0499986 3.6358833e-6))
))
(defvar *ds2* '((-1.0 0.0 1.0 2.0 3.0)
@ -80,6 +82,6 @@
(deftest test-quad ()
(let (ps2 objective)
(setf ps2 (decons:quad (car *ds2*)))
(setf ps2 (mlx:quad (car *ds2*)))
(== (funcall ps2 '(1.0 0.0 0.0)) '(1.0 0.0 1.0 4.0 9.0))
))