;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               interleave.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;    
;;;;    Compute and draw interleave and deinterleave permutations.
;;;;    
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2009-08-26 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;    
;;;;    Copyright Pascal J. Bourguignon 2009 - 2009
;;;;    
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
;;;;    
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
;;;;    
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************


(defun iota (count &optional start step)
  "
RETURN:   A list containing the elements 
          (start start+step ... start+(count-1)*step)
          The start and step parameters default to 0 and 1, respectively. 
          This procedure takes its name from the APL primitive.
EXAMPLES: (iota 5) => (0 1 2 3 4)
          (iota 5 0 -0.1) => (0 -0.1 -0.2 -0.3 -0.4)
"
  (setf start (or start 0) step (or step 1))
  (when (< 0 count)
    (do ((result '())
         (item (+ start (* step (1- count))) (- item step)))
        ((< item start) result)
      (push item result))))


;; (0 1 2 3 4 5 6 7 8 9)
;; (0 1 2 3 4          )
;; (          5 6 7 8 9)
;; (0   1   2   3   4  )
;; (  5   6   7   8   9)
;; (0 5 1 6 2 7 3 8 4 9)
;; 
;; (0 1 2 3 4 5 6 7 8 9)
;; (0 5 1 6 2 7 3 8 4 9)

(defun draw-interleave (length)
  (flet ((pp (s) (format t "(~{~2A~^ ~})~%" s)))
    (pp (iota length))
    (pp (append (iota (/ length 2))
                (make-list  (/ length 2) :initial-element "")))
    (pp (append (make-list  (/ length 2) :initial-element "")
                (iota (/ length 2)  (/ length 2))))
    (pp (loop :for i :from 0 :below (/ length 2)
           :collect i :collect ""))
    (pp (loop :for i :from (/ length 2) :below length
           :collect "" :collect i))
    (pp (coerce (interleave-permutation length) 'list)))
  (values))


(defun interleave-permutation (length)
  "Returns the interleave permutation of the vector (iota length)."
  (assert (evenp length))
  (coerce (loop
             :for l :from 0 :below (/ length 2)
             :for r :from (/ length 2)
             :collect l :collect r) 'vector))

;; (interleave-permutation 20)
;; --> #(0 10 1 11 2 12 3 13 4 14 5 15 6 16 7 17 8 18 9 19)

(defun permutation-cycles (permutation)
  "
PERMUTATION:    A permutation of (iota (length permutation))
RETURN:         A list of cycles in the permutation.
                Each cycle is represented by an open path of the cycle
                The order of the cycles is unspecified.
                The starting element of the cycles is unspecified.
                The meaning of (a0... ai aj ... an) is that
                the aith element goes to the ajth position, and
                the anth element goes to the a0th position.
EXAMPLE:        (permutation-cycles #(1 2 3 0 4 6 7 8 5))
                 --> ((0 1 2 3) (4) (5 6 7 8))
"
  (loop
     :with cycles = '()
     :with walked = (make-array (length permutation) :initial-element nil)
     :for i :from 0 :below (length permutation)
     :do (unless (aref walked i)
           (loop
              :with cycle = '()
              :for k = i :then (elt permutation k)
              :until (aref walked k)
              :do (push k cycle) (setf (aref walked k) t)
              :finally (push cycle cycles)))
     :finally (return cycles)))


;; (values (iota 16)  (interleave-permutation 16) (permutation-cycles (interleave-permutation 16)))
;; -->
;;  (00 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15)
;; #(00 08 01 09 02 10 03 11 04 12 05 13 06 14 07 15)
;; ((15) (14 13 11 07) (10 05) (06 12 09 03) (02 04 08 01) (00))


(defun generate-cycle-swaps (cycle vector-name)
  "
CYCLE:          A list of positions.
                The meaning of (a0... ai aj ... an) is that
                the aith element goes to the ajth position, and
                the anth element goes to the a0th position.
RETURN:         Code implementing the permutation corresponding to the
                cycle shifting.
"
  (case (length cycle)
    ((0 1) '(progn))                  ; nothing to do.
    ((2)    `(rotatef (elt ,vector-name ,(first cycle))
                      (elt ,vector-name ,(second cycle))))
    (otherwise
     `(let ((t1 (elt ,vector-name ,(first cycle)))
            t2)
        ,@(loop
             :for step :from 0
             :for j :in (rest cycle)
             :collect (if (evenp step)
                          `(setf t2 (elt ,vector-name ,j)
                                 (elt ,vector-name ,j) t1)
                          `(setf t1 (elt ,vector-name ,j)
                                 (elt ,vector-name ,j) t2)) :into expressions
             :finally (return (append expressions
                                      (list (if (evenp step)
                                                `(setf (elt ,vector-name ,(first cycle)) t1)
                                                `(setf (elt ,vector-name ,(first cycle)) t2))))))))))

;; (setf *print-circle* nil
;;       *PRINT-PRETTY* t)
;; 
;; (mapcar (lambda (cycle) (generate-cycle-swaps cycle 'vector))
;;         (permutation-cycles (interleave-permutation 16)))
;; -->
;; ((PROGN)
;;  (LET ((T1 (ELT VECTOR 14)) T2)
;;    (SETF T2 (ELT VECTOR 13) (ELT VECTOR 13) T1)
;;    (SETF T1 (ELT VECTOR 11) (ELT VECTOR 11) T2)
;;    (SETF T2 (ELT VECTOR 7) (ELT VECTOR 7) T1)
;;    (SETF (ELT VECTOR 14) T2))
;;  (ROTATEF (ELT VECTOR 10) (ELT VECTOR 5))
;;  (LET ((T1 (ELT VECTOR 6)) T2)
;;    (SETF T2 (ELT VECTOR 12) (ELT VECTOR 12) T1)
;;    (SETF T1 (ELT VECTOR 9) (ELT VECTOR 9) T2)
;;    (SETF T2 (ELT VECTOR 3) (ELT VECTOR 3) T1)
;;    (SETF (ELT VECTOR 6) T2))
;;  (LET ((T1 (ELT VECTOR 2)) T2)
;;    (SETF T2 (ELT VECTOR 4) (ELT VECTOR 4) T1)
;;    (SETF T1 (ELT VECTOR 8) (ELT VECTOR 8) T2)
;;    (SETF T2 (ELT VECTOR 1) (ELT VECTOR 1) T1)
;;    (SETF (ELT VECTOR 2) T2))
;;  (PROGN))


(defun generate-interleave (name length)
  (assert (and (not (minusp length)) (evenp length)))
  `(defun ,name (vector)
     (assert (= ,length (length vector)))
     ,@(mapcar (lambda (cycle) (generate-cycle-swaps cycle 'vector))
               (permutation-cycles (interleave-permutation length)))
     vector))

(defun generate-deinterleave (name length)
  (assert (and (not (minusp length)) (evenp length)))
  `(defun ,name (vector)
     (assert (= ,length (length vector)))
     ,@(mapcar (lambda (cycle) (generate-cycle-swaps (reverse cycle) 'vector))
               (permutation-cycles (interleave-permutation length)))
     vector))

(defmacro define-interleave-functions (interleave-name deinterleave-name length)
  `(values
     ,(generate-interleave   interleave-name   length)
     ,(generate-deinterleave deinterleave-name length)))


;; (generate-interleave 'interleave-16 16)
;; -->
;; (DEFUN INTERLEAVE-16 (VECTOR)
;;   (ASSERT (= 16 (LENGTH VECTOR)))
;;   (PROGN)
;;   (LET ((T1 (ELT VECTOR 14)) T2)
;;     (SETF T2 (ELT VECTOR 13) (ELT VECTOR 13) T1)
;;     (SETF T1 (ELT VECTOR 11) (ELT VECTOR 11) T2)
;;     (SETF T2 (ELT VECTOR 7) (ELT VECTOR 7) T1)
;;     (SETF (ELT VECTOR 14) T2))
;;   (ROTATEF (ELT VECTOR 10) (ELT VECTOR 5))
;;   (LET ((T1 (ELT VECTOR 6)) T2)
;;     (SETF T2 (ELT VECTOR 12) (ELT VECTOR 12) T1)
;;     (SETF T1 (ELT VECTOR 9) (ELT VECTOR 9) T2)
;;     (SETF T2 (ELT VECTOR 3) (ELT VECTOR 3) T1)
;;     (SETF (ELT VECTOR 6) T2))
;;   (LET ((T1 (ELT VECTOR 2)) T2)
;;     (SETF T2 (ELT VECTOR 4) (ELT VECTOR 4) T1)
;;     (SETF T1 (ELT VECTOR 8) (ELT VECTOR 8) T2)
;;     (SETF T2 (ELT VECTOR 1) (ELT VECTOR 1) T1)
;;     (SETF (ELT VECTOR 2) T2))
;;   (PROGN)
;;   VECTOR)

;; (generate-deinterleave 'deinterleave-16 16)
;; -->
;; (DEFUN DEINTERLEAVE-16 (VECTOR)
;;   (ASSERT (= 16 (LENGTH VECTOR)))
;;   (PROGN)
;;   (LET ((T1 (ELT VECTOR 7)) T2)
;;     (SETF T2 (ELT VECTOR 11) (ELT VECTOR 11) T1)
;;     (SETF T1 (ELT VECTOR 13) (ELT VECTOR 13) T2)
;;     (SETF T2 (ELT VECTOR 14) (ELT VECTOR 14) T1)
;;     (SETF (ELT VECTOR 7) T2))
;;   (ROTATEF (ELT VECTOR 5) (ELT VECTOR 10))
;;   (LET ((T1 (ELT VECTOR 3)) T2)
;;     (SETF T2 (ELT VECTOR 9) (ELT VECTOR 9) T1)
;;     (SETF T1 (ELT VECTOR 12) (ELT VECTOR 12) T2)
;;     (SETF T2 (ELT VECTOR 6) (ELT VECTOR 6) T1)
;;     (SETF (ELT VECTOR 3) T2))
;;   (LET ((T1 (ELT VECTOR 1)) T2)
;;     (SETF T2 (ELT VECTOR 8) (ELT VECTOR 8) T1)
;;     (SETF T1 (ELT VECTOR 4) (ELT VECTOR 4) T2)
;;     (SETF T2 (ELT VECTOR 2) (ELT VECTOR 2) T1)
;;     (SETF (ELT VECTOR 1) T2))
;;   (PROGN)
;;   VECTOR)

;; (define-interleave-functions interleave-16 deinterleave-16 16)
;; -->
;; INTERLEAVE-16
;; DEINTERLEAVE-16
;; 
;; (interleave-16 (iota 16))
;; -->
;; (0 8 1 9 2 10 3 11 4 12 5 13 6 14 7 15)
;; 
;; (deinterleave-16 (interleave-16 (iota 16)))
;; -->
;; (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)



(defun execute-cycle-swaps (cycle vector)
  "
CYCLE:          A list of positions.
                The meaning of (a0... ai aj ... an) is that
                the aith element goes to the ajth position, and
                the anth element goes to the a0th position.
DO:             Rotate the elements of vector according to the cycle.

"
  (case (length cycle)
    ((0 1))                             ; nothing to do.
    ((2)    (rotatef (elt vector (first cycle))
                     (elt vector (second cycle))))
    (otherwise
     (let ((t1 (elt vector (first cycle)))
           t2)
       (loop
          :for step :from 0
          :for j :in (rest cycle)
          :do (if (evenp step)
                  (setf t2 (elt vector j)
                        (elt vector j) t1)
                  (setf t1 (elt vector j)
                        (elt vector j) t2))
          :finally (if (evenp step)
                       (setf (elt vector (first cycle)) t1)
                       (setf (elt vector (first cycle)) t2))))))
  vector)


(defun interleave (vector)
  (let ((length (length vector)))
   (assert (evenp length))
   (dolist (cycle (permutation-cycles (interleave-permutation length)))
     (execute-cycle-swaps cycle vector))
   vector))

(defun deinterleave (vector)
  (let ((length (length vector)))
    (assert (evenp length))
    (dolist (cycle (permutation-cycles (interleave-permutation length)))
      (execute-cycle-swaps (reverse cycle) vector))
    vector))


(let ((*PRINT-RIGHT-MARGIN* 200))
  (loop
     :for n :from 2 :to 32 :by 2
     :initially (terpri)
     :do  (format t "~20A ~3D  ~28A  ~A~%"
                  (COM.INFORMATIMAGO.COMMON-LISP.PRIMES:FACTORIZE n)
                  (length (permutation-cycles (interleave-permutation n)))
                  (format nil "~{~2D ~}"
                          (mapcar (function length)
                                   (permutation-cycles (interleave-permutation n))))
                  (permutation-cycles (interleave-permutation n)))))


(defparameter *colors*
  '("red" "green" "blue" "yellow" "magenta" "cyan"
    "brown" "violet" "orange"
    "blue3" "IndianRed3" "LightYellow3" "DarkSeaGreen3" "bisque3"
    "PeachPuff3" "turquoise3" "LemonChiffon3" "cornsilk3" "ivory3"
    "honeydew3" "LavenderBlush3" "MistyRose3" "azure3" "SlateBlue3"
    "RoyalBlue3" "DodgerBlue3" "SteelBlue3" "DeepSkyBlue3"
    "SkyBlue3" "LightSkyBlue3" "SlateGray3" "LightSteelBlue3" "LightBlue3"
    "LightCyan3" "PaleTurquoise3" "CadetBlue3"  "cyan3"
    "DarkSlateGray3" "aquamarine3"  "SeaGreen3"
    "PaleGreen3" "SpringGreen3" "green3" "chartreuse3" "OliveDrab3"
    "DarkOliveGreen3" "khaki3" "LightGoldenrod3"  "yellow3"
    "gold3" "goldenrod3" "DarkGoldenrod3" "RosyBrown3" 
    "sienna3" "burlywood3" "wheat3" "tan3" "chocolate3" "firebrick3"
    "brown3" "salmon3" "LightSalmon3" "orange3" "DarkOrange3" "coral3"
    "tomato3" "OrangeRed3" "red3" "DeepPink3" "HotPink3" "pink3"
    "LightPink3" "PaleVioletRed3" "maroon3" "VioletRed3" "magenta3"
    "orchid3" "plum3" "MediumOrchid3" "DarkOrchid3" "purple3"
    "MediumPurple3" "thistle3" . #1=("black" . #1#)))


(defmacro rank ((stream reference) &body body)
  (let ((vstream (gensym))
        (vreference (gensym)))
    `(let ((,vstream ,stream)
           (,vreference ,reference))
       (unwind-protect (progn
                         (format ,vstream "{ rank=same; ~:[~;~:*\"~A\";~] ~%" ,vreference)
                         ,@body)
         (format ,vstream "~&}~%")))))

(defun  afine (x min-x max-x min-y max-y)
  (+ (* (/ (- x min-x) max-x) (- max-y min-y)) min-y))

(defun write-dot-graph (length &key show)
  (let ((gname (format nil "graph-~2,'0D"      length))
        (iname (format nil "interleave-~2,'0D" length))
        (cname (format nil "circle-~2,'0D"     length)))
    (macrolet ((gen ((name) &body body)
                 `(with-open-file (dot (format nil "~A.dot" ,name)
                                       :direction :output
                                       :if-does-not-exist :create
                                       :if-exists :supersede)
                    (format dot "digraph \"~A\" {~%" ,name)
                    ,@body
                    (format dot "}~%"))))
      (gen (gname)
           (format dot "node [shape=plaintext, fontsize=10];~%")
           (format dot "edge [color=white];~%")
           (format dot "rankdir=LR;~%")
           (format dot "ranksep=~F;~%" (afine length 0 100 1 6))
           (format dot "~A[shape=\"record\",label=\"~{<~A> ~:*~A~^|~}\"];~%" 'src (iota length))
           (format dot "~A[shape=\"record\",label=\"~{<~A> ~:*~A~^|~}\"];~%" 'dst (iota length))
           (loop
              :for cycle :in (permutation-cycles (interleave-permutation length))
              :for color :in *colors*
              :do (format dot "edge [color=~A];~%" color)
              :do (loop
                     :for (i j) :on cycle
                     :do (format dot "~A:~A -> ~A:~A~%" 'src i 'dst (or j (first cycle))))))
      (gen (iname)
           (format dot "node [shape=plaintext, fontsize=10];~%")
           (format dot "edge [style=invis];~%")
           (format dot "rankdir=LR;~%")
           (format dot "ranksep=~F;~%" (afine length 0 100 1 6))
           (format dot "~A[shape=\"record\",label=\"~{<~A> ~:*~A~^|~}\"];~%" 'INT (interleave (iota length))))

      (gen (cname)
           (format dot "node[shape=rectangle,height=0.1,width=0.1];~%")
           (format dot "edge [style=invis];~%")
           (loop
              :for i :from 0 :below length
              :do (loop
                     :for j :from 0 :below length
                     :unless (= i j) :do (format dot "~A->~A;~%" i j)))
           ;; (loop
           ;;    :for (i j) :on (iota length)
           ;;    :do (format dot "~A->~A;" i (or j 0)))
           (format dot "edge [style=solid];~%")
           (loop
              :for cycle :in (permutation-cycles (interleave-permutation length))
              :for color :in *colors*
              :do (format dot "edge [color=~A];~%" color)
              :do (loop
                     :for (i j) :on cycle
                     :do (format dot "~A -> ~A~%"  i (or j (first cycle)))))))
    (ext:shell (format nil "dot   -Tpng ~A.dot > ~:*~A.png"  gname))
    (ext:shell (format nil "dot   -Tpng ~A.dot > ~:*~A.png"  iname))
    (ext:shell (format nil "circo -Tpng ~A.dot > ~:*~A.png"  cname))))

(defun generate-pictures ()
 (loop
    :for length :from 2 :to 98 :by 2
    :do (princ ".") (force-output) (write-dot-graph length)
    :finally (return :done)))


(defun html-factorization (factorization)
  (format nil "~{~A~^ * ~}"
          (mapcar (lambda (factor)
                    (if (integerp factor)
                        (prin1-to-string factor)
                        (format nil "~A<sup>~A</sup>"
                                (second factor)
                                (third factor))))
                  (rest factorization))))

(defun generate-index ()
 (with-open-file (html "index.html"
                       :direction :output
                       :if-does-not-exist :create
                       :if-exists :supersede)
   (write-line "<html><head><title>Interleave</title></head>"  html)
   (write-line "<body>" html)
   (write-line "<p>The following diagrams are generated by <a href=\"http://www.graphviz.org/\">
Graphviz</a> from .dot files generated by <a href=\"interleave.lisp\">interleave.lisp</a>.</p>" html)
   (loop
      :for length :from 2 :to 98 :by 2
      :for cycles =   (permutation-cycles (interleave-permutation length))
      :for lf   = (COM.INFORMATIMAGO.COMMON-LISP.PRIMES:FACTORIZE length)
      :for l-2f = (COM.INFORMATIMAGO.COMMON-LISP.PRIMES:FACTORIZE (- length 2))
      :do (let  ((gname (format nil "graph-~2,'0D"      length))
                 (iname (format nil "interleave-~2,'0D" length))
                 (cname (format nil "circle-~2,'0D"     length)))
            (let ((width (with-open-stream (size (ext:run-shell-command
                                                  (format nil "(pngtopnm<~A.png|head -2)" cname)
                                                  :output :stream))
                           (read size)  (read size))))
              (print width)
              (format html "<p><strong>~D</strong><br>~D cycles, of lengths: ~{~A~^, ~}.<br>~A<br>~%"
                      length (length cycles) (mapcar (function length) cycles) cycles)
              (format html "~D = ~A<br>~%" length (html-factorization lf))
              (format html "~D = ~A<br>~%" (- length 2) (html-factorization l-2f))
              (format html "<img src=\"~A.png\">&nbsp;~
                           <img src=\"~A.png\"><br>~
                           <img src=\"~A.png\" width=\"~D\"><br>~
                           <hr>~%" gname iname cname (min width 748)))))
   (write-line "</body></html>" html)
   :done))

;; (progn (generate-pictures) (generate-index))