;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*

(in-package :kenzo-test)

(in-suite :kenzo)

(test random-matrix
      (cat:random-matrix 2 3 10))


(test idnt-mtrx
      (cat:idnt-mtrx 3))


(test copy-mtrx
      (let ((m (cat:random-matrix 3 4 10)))
        (is (equalp m (cat:copy-mtrx m)))))


(test left-submatrix
      (let ((m (cat:random-matrix 3 4 10)))
        (cat:left-submatrix m 2)))


(test mtrx-prdc
      (let ((m1 (cat:random-matrix 2 3 10))
            (m2 (cat:random-matrix 3 2 10)))
        (cat:mtrx-prdc m1 m2)
        (cat:mtrx-prdc m2 m1)))


(test chcm-mtrx
      (cat:cat-init)
      (let ((d (cat:delta 5))
            (m (cat:moore 2 2)))
        (cat:chcm-mtrx d 3)
        (dotimes (i 5)
          (print (cat:chcm-mtrx m i)))
        (dotimes (i 6)
          (print (array-dimensions (cat:chcm-mtrx m i))))))


(test line-op
      (let ((m (cat:random-matrix 3 4 10)))
        (cat:line-op m 1 3 2 0)))

;; mtrx-list = (P P^-1 M Q Q^-1)

(test line-op-5
      (let* ((p (cat:idnt-mtrx 4))
             (p-1 (cat:idnt-mtrx 4))
             (m (cat:random-matrix 4 5 10))
             (q (cat:idnt-mtrx 5) )
             (q-1 (cat:idnt-mtrx 5))
             (list (list p p-1 m q q-1))
             (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:line-op-5 list 0 3 1 3)
        (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:mtrx-prdc p p-1)))


(test column-op
      (let ((m (cat:random-matrix 3 4 10)))
        (cat:column-op m 1 3 2 0)))


(test column-op-5
      (let* ((p (cat:idnt-mtrx 4))
             (p-1 (cat:idnt-mtrx 4))
             (m (cat:random-matrix 4 5 10))
             (q (cat:idnt-mtrx 5))
             (q-1 (cat:idnt-mtrx 5))
             (list (list p p-1 m q q-1))
             (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:column-op-5 list 0 3 1 3)
        (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:mtrx-prdc p p-1)
        (cat:mtrx-prdc q q-1)))


(test line-swap
      (let ((m (cat:random-matrix 3 4 10)))
        (cat:line-swap m 1 0 2)))


(test line-swap-5
      (let* ((p (cat:idnt-mtrx 4))
             (p-1 (cat:idnt-mtrx 4))
             (m (cat:random-matrix 4 5 10))
             (q (cat:idnt-mtrx 5))
             (q-1 (cat:idnt-mtrx 5))
             (list (list p p-1 m q q-1))
             (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:line-swap-5 list 0 1 3)
        (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:mtrx-prdc p p-1)
        (cat:mtrx-prdc q q-1)))


(test column-swap
      (let ((m (cat:random-matrix 3 4 10)))
        (cat:column-swap m 1 0 2)))


(test column-swap-5
      (let* ((p (cat:idnt-mtrx 4))
             (p-1 (cat:idnt-mtrx 4))
             (m (cat:random-matrix 4 5 10))
             (q (cat:idnt-mtrx 5))
             (q-1 (cat:idnt-mtrx 5))
             (list (list p p-1 m q q-1))
             (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:column-swap-5 list 0 1 3)
        (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:mtrx-prdc p p-1)
        (cat:mtrx-prdc q q-1)))


(test column-minus
      (let ((m (cat:random-matrix 3 4 10)))
        (cat:line-minus m 1 2)
        (cat:column-minus m 1 2)))


(test column-minus-5
      (let* ((p (cat:idnt-mtrx 4))
             (p-1 (cat:idnt-mtrx 4))
             (m (cat:random-matrix 4 5 10))
             (q (cat:idnt-mtrx 5))
             (q-1 (cat:idnt-mtrx 5))
             (list (list p p-1 m q q-1))
             (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:line-minus-5 list 0 3)
        (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:mtrx-prdc p p-1)
        (cat:mtrx-prdc q q-1)
        (cat:column-minus-5 list 0 2)
        (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:mtrx-prdc p p-1)
        (cat:mtrx-prdc q q-1)))


(test minimal-term
      (let ((m (cat:random-matrix 4 5 10)))
        (cat:minimal-term m 1)))


#|
;; potential divide by 0
(test minimal-rest-1
      (let ((m (cat:random-matrix 4 5 10)))
        (cat:minimal-rest-1 m 1)))

(test minimal-rest-2
      (let ((m (cat:random-matrix 4 5 10)))
        (cat:minimal-rest-2 m 1)))
|#


(test minimal-term-top-left
      (let* ((p (cat:idnt-mtrx 4))
             (p-1 (cat:idnt-mtrx 4))
             (m (cat:random-matrix 4 5 10))
             (q (cat:idnt-mtrx 5))
             (q-1 (cat:idnt-mtrx 5))
             (list (list p p-1 m q q-1))
             (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:minimal-term-top-left list 0 1 3)
        (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:mtrx-prdc p p-1)
        (cat:mtrx-prdc q q-1)))


(test minimal-term-top-left1
      (let* ((p (cat:idnt-mtrx 4))
             (p-1 (cat:idnt-mtrx 4))
             (m (cat:random-matrix 4 5 10))
             (q (cat:idnt-mtrx 5))
             (q-1 (cat:idnt-mtrx 5))
             (list (list p p-1 m q q-1))
             (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:pivott list 0)
        (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:mtrx-prdc p p-1)
        (cat:mtrx-prdc q q-1)))


(test list-smith
      (let* ((p (cat:idnt-mtrx 4))
             (p-1 (cat:idnt-mtrx 4))
             (m (cat:random-matrix 4 5 10))
             (q (cat:idnt-mtrx 5))
             (q-1 (cat:idnt-mtrx 5))
             (list (list p p-1 m q q-1))
             (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (third (cat:list-smith list))
        (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
        (cat:mtrx-prdc p p-1)
        (cat:mtrx-prdc q q-1)))


(test gnrt-name-basis
      (cat:gnrt-name 4)
      (cat:gnrt-name-basis 4))


(test echcm-kill-epi-f-intr
      (let* ((q-1 (cat:random-matrix 5 5 10))
             (f (cat:echcm-kill-epi-f-intr #'cat:s-cmpr 2 2 5 '(a b c d e)
                                           (list 0 0 0 0 q-1))))
        (funcall f (cat:cmbn 2 1 'a))
        (funcall f (cat:cmbn 4 1 'a))
        (funcall f (cat:cmbn 3 1 'a 10 'b 100 'c 1000 'd 10000 'e))))

#|
(test echcm-kill-epi-g-intr
      (let* ((q (cat:random-matrix 5 5 10))
             (g (cat:echcm-kill-epi-g-intr 2 2 5 '(a b c d e)
                                           (list 0 0 0 q 0))))
        (funcall g (cat:cmbn 2))
        (funcall g (cat:cmbn 4 1 'a))
        (funcall g (cat:cmbn 3 1 :gn-0 10 :gn-1 100 :gn-2))))
|#

(test echcm-kill-epi-h-intr
      (let* ((p-1 (cat:random-matrix 2 2 10))
             (q (cat:random-matrix 5 5 10))
             (h (cat:echcm-kill-epi-h-intr #'cat:s-cmpr 2 2 5 '(a b)
                                           '(a b c d e)
                                           (list 0 p-1 0 q 0))))
        (funcall h (cat:cmbn 2 1 'a 1000 'b))
        (funcall h (cat:cmbn 4 1 'a))))


(test echcm-kill-epi
      (cat:cat-init)
      (let* ((s3 (cat:sphere 3))
             (s3-chml-clss (cat:chml-clss s3 3))
             (s3-fibration (cat:z-whitehead s3 s3-chml-clss))
             (s3-4 (cat:fibration-total s3-fibration))
             (ecc (cat:echcm s3-4))
             (rdct (cat:echcm-kill-epi ecc 2))
             s3-4-chml-clss s3-4-fibration s3-5
             rdct1 rdct2 rdct3 rdct12 rdct123)
        (cat:pre-check-rdct rdct)
        (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc))
              cat:*bc* cat:*tc*)
        (check-rdct)
        (setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2))))
        (check-rdct)
        (setf cat:*tc* (cat:cmbn 3 1 (first (cat:basis ecc 3))))
        (check-rdct)
        (setf cat:*tc* (cat:cmbn 4 1 (first (cat:basis ecc 4)))
              cat:*bc* cat:*tc*)
        (check-rdct)
        (setf s3-4-chml-clss (cat:chml-clss s3-4 4))
        (setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
        (setf s3-5 (cat:fibration-total s3-4-fibration))
        (setf ecc (cat:echcm s3-5))
        (dotimes (i 7)
          (format t "~%DIM = ~D ; LENGTH = ~D" i (length (cat:basis ecc i))))
        (setf rdct1 (cat:echcm-kill-epi ecc 2))
        (setf rdct2 (cat:echcm-kill-epi (cat:bcc rdct1) 3))
        (setf rdct3 (cat:echcm-kill-epi (cat:bcc rdct2) 4))
        (setf rdct12 (cat:cmps rdct2 rdct1))
        (setf rdct123 (cat:cmps rdct3 rdct12))
        (cat:pre-check-rdct rdct123)
        (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc)) cat:*bc* cat:*tc*)
        (check-rdct)
        (setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2))))
        (check-rdct)
        (let ((b3 (cat:basis ecc 3)))
          (setf cat:*tc* (cat:cmbn 3 1 (first b3) 10 (second b3))))
        (check-rdct)
        (let ((b4 (cat:basis ecc 4)))
          (setf cat:*tc* (cat:cmbn 4 1 (first b4) 10 (second b4))))
        (check-rdct)
        (let ((b5 (cat:basis ecc 5)))
          (setf cat:*tc* (cat:cmbn 5 1 (first b5)
                                   10 (second b5)
                                   100 (third b5)
                                   1000 (fourth b5))))
        (check-rdct)
        (let ((b6 (cat:basis ecc 6)))
          (setf cat:*tc* (cat:cmbn 6 1 (first b6)
                                   10 (second b6)
                                   100 (third b6)
                                   1000 (fourth b6)
                                   10000 (fifth b6)
                                   100000 (sixth b6)
                                   1000000 (seventh b6))))
        (check-rdct)))


(test kill-epis
      (cat:cat-init)
      (let* ((s3 (cat:sphere 3))
             (s3-chml-clss (cat:chml-clss s3 3))
             (s3-fibration (cat:z-whitehead s3 s3-chml-clss))
             (s3-4 (cat:fibration-total s3-fibration))
             (s3-4-chml-clss (cat:chml-clss s3-4 4))
             (s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
             (s3-5 (cat:fibration-total s3-4-fibration)))
        (time (cat:homology s3-5 6))
        (cat:kill-epis s3-5 2 5)
        (cat:homology s3-5 0 7)))


(test kill-epi
      (cat:cat-init)
      (let* ((s3 (cat:sphere 3))
             (s3-chml-clss (cat:chml-clss s3 3))
             (s3-fibration (cat:z-whitehead s3 s3-chml-clss))
             (s3-4 (cat:fibration-total s3-fibration))
             s3-4-chml-clss s3-4-fibration s3-5)
        (cat:kill-epi s3-4 2)
        (setf s3-4-chml-clss (cat:chml-clss s3-4 4))
        (setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
        (setf s3-5 (cat:fibration-total s3-4-fibration))
        (time (cat:homology s3-5 6))))


(test chml-clss-intr
      (cat:cat-init)
      (let* ((s3 (cat:sphere 3))
             (c (cat:chml-clss-intr s3 3))
             (s3-chml-clss (cat:chml-clss s3 3))
             (s3-fibration (cat:z-whitehead s3 s3-chml-clss))
             (s3-4 (cat:fibration-total s3-fibration))
             s3-4-chml-clss s3-4-fibration s3-5)
        (funcall c (cat:cmbn 3 5 's3))
        (cat:kill-epi s3-4 2)
        (setf c (cat:chml-clss-intr s3-4 4))
        (funcall c (cat:cmbn 4 5 (first (cat:basis (cat:echcm s3-4) 4))))
        (setf s3-4-chml-clss (cat:chml-clss s3-4 4))
        (setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
        (setf s3-5 (cat:fibration-total s3-4-fibration))
        (cat:kill-epis s3-5 3 5)
        (setf c (cat:chml-clss-intr s3-5 5))
        (let ((b5 (cat:basis (cat:echcm s3-5) 5)))
          (funcall c (cat:cmbn 5 1 (first b5) 10 (second b5))))))


(test chml-clss
      (cat:cat-init)
      (let* ((s3 (cat:sphere 3))
             (s3-chml-clss (cat:chml-clss s3 3))
             (s3-fibration (cat:z-whitehead s3 s3-chml-clss))
             (s3-4 (cat:fibration-total s3-fibration))
             s3-4-chml-clss s3-4-fibration s3-5 s3-5-chml-clss s3-5-fibration)
        (cat:homology s3-4 0 6)
        (cat:kill-epi s3-4 2)
        (setf s3-4-chml-clss (cat:chml-clss s3-4 4))
        (setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
        (setf s3-5 (cat:fibration-total s3-4-fibration))
        (cat:homology s3-5 0 6)
        (cat:kill-epis s3-5 3 5)
        (setf s3-5-chml-clss (cat:chml-clss s3-5 5))
        (setf s3-5-fibration (cat:z2-whitehead s3-5 s3-5-chml-clss))
        (setf s3-6 (cat:fibration-total s3-5-fibration))
        (cat:homology s3-6 0 7)))