Improve SeqN Gapply Code

Improves SeqN Gapply Code
anoma · Oct 10, 2023 · 210e6fb · 210e6fb
1 parent 5bcfc00
commit 210e6fb
Showing 1 changed file with 23 additions and 18 deletions.
diff --git a/src/seqn/seqn.lisp b/src/seqn/seqn.lisp
@@ -133,12 +133,13 @@ is capable of succesfully evaluating all compiled terms"
     (id               vector)
     (composition      (gapply (mcar morphism)
                               (gapply (mcadr morphism) vector)))
-    (parallel-seq     (append (gapply (mcar morphism)
-                                      (subseq vector
-                                              0 (length (dom (mcar morphism)))))
-                              (gapply (mcadr morphism)
-                                      (subseq vector
-                                              (length (dom (mcar morphism)))))))
+    (parallel-seq     (let ((lng (length (dom (mcar morphism)))))
+                        (append (gapply (mcar morphism)
+                                        (subseq vector
+                                                0 lng))
+                                (gapply (mcadr morphism)
+                                        (subseq vector
+                                                lng)))))
     (fork-seq         (append vector vector))
     (drop-nil         (list 0))
     (remove-right     (butlast vector))
@@ -151,15 +152,17 @@ is capable of succesfully evaluating all compiled terms"
                                          :initial-element 0)
                               vector))
     (inj-size         vector)
-    (branch-seq       (if (= 0 (car vector))
-                          (gapply (mcar morphism)
-                                  (cdr vector))
-                          (gapply (mcadr morphism)
-                                  (cdr vector))))
-    (shift-front      (append (cons (nth (1- (mcadr morphism))
-                                         vector)
-                                    (subseq vector 0 (1- (mcadr morphism))))
-                              (subseq vector (mcadr morphism))))
+    (branch-seq       (let ((cdr (cdr vector)))
+                        (if (= 0 (car vector))
+                            (gapply (mcar morphism)
+                                    cdr)
+                            (gapply (mcadr morphism)
+                                    cdr))))
+    (shift-front     (let ((mcadr (1- (mcadr morphism))))
+                       (append (cons (nth mcadr
+                                          vector)
+                                     (subseq vector 0 mcadr))
+                               (subseq vector (mcadr morphism)))))
     (zero-bit         (list 0))
     (one-bit          (list  1))
     (seqn-add         (list (+ (car vector) (cadr vector))))
@@ -170,9 +173,11 @@ is capable of succesfully evaluating all compiled terms"
     (seqn-nat         (list (mcadr morphism)))
     (seqn-concat      (list (+ (* (expt 2 (mcadr morphism)) (car vector))
                                (cadr vector))))
-    (seqn-decompose   (if (>= (car vector)  (expt 2 (1- (mcar morphism))))
-                          (list 1 (- (car vector) (expt 2 (1- (mcar morphism)))))
-                          (list 0 (car vector))))
+    (seqn-decompose   (let ((car (car vector))
+                            (exp (expt 2 (1- (mcar morphism)))))
+                        (if (>= car exp)
+                            (list 1 (- car exp))
+                            (list 0 car))))
     (seqn-eq          (if (= (car vector) (cadr vector))
                           (list 0 0)
                           (list 1 0)))