;;;; modelb1.lsp
;;;
;;; based on modelf6.lsp,
;;; but renamed because
;;;     - deletion of modelf functions to ease maintenance
;;;     - refer to modelf6.lsp to see how there were done -- though not maintained from modelf3 on
;;;     - makes add-nogoods very efficient
;;; many other functions removed
;;; same-modelabcd not being maintained but might work!

;;;; modelf6.lsp
;;; use all-conflicts as vector instead of list, and reuse it through r-permute-vector-d

;; modelf5.lsp
;; much more efficient version of r-permute

;; modelf4.lsp
;; started by Ian Gent, 1/01/2002
;; based on modelf3 used in Random Problems flaws paper
;; For writing out in Dimacs format


;; modelf3.lsp

;; modelf and modelf2 were BUGGED
;; as may be parts of this one
;; The same constraint graph would be used throughout each sample.
;; model-abcd replaces old versions, and takes an arbitrary
;;  graph generator
;;	either function of 2 arguments, e and n
;;	or graph (as list) to be used for all problems
;; nogoods generator
;;	function of lots of ugly arguments, see below for details
;;		is used for each constraint.

;; modelf2.lsp written or largely written by Toby Walsh

;; modelf2.lsp
;; intended to allow variety in generation of conflict matrices

(defvar *csp-start-run-time*)
(defvar *csp-start-real-time*)
(defvar *csp-last-run-time*)
(defvar *csp-last-real-time*)

(defvar *sat-start-run-time*)
(defvar *sat-start-real-time*)
(defvar *sat-last-run-time*)
(defvar *sat-last-real-time*)

;; model-abcd
;; 	generates problems via models A to D, i.e assumes list of
;;      edges chosen and picks all conflicts for each constraint at once.


(defun model-abcd  (elist-generator nnn mmm p1 nogoods-generator p2 outfile
                         &optional (sample 1) (name "model-ABCD")
                                   (outputfunc #'output-csp-apes-str))
   (with-open-file (str outfile :direction :output)
     (format str "~%Problems ~A ~%" sample)
     (dotimes (i sample)
              (setf *csp-start-run-time* (get-internal-run-time)
                    *csp-start-real-time* (get-internal-real-time))
	     (let ((elist (if (or (functionp elist-generator)
				  (not (listp elist-generator)))
			      (funcall elist-generator
				       (round (* nnn (- nnn 1) 1/2 p1))
				       nnn)
			      elist-generator)))
		  (model-abcd-str
		   (edges-normalise elist)
		   nogoods-generator nnn mmm p2 str (+ i 1) name outputfunc)))))

(defun model-abcd-str (elist nogoods-generator nnn mmm p2 str
		&optional (ident 1)
                         (generator-name "model-ABCD")
                         (outputfunc #'output-csp-apes-str))
   (let ((amatrix (elist2amatrix elist nnn))
	(allconflicts-vec (apply #'vector (all-conflicts mmm)))
	(numnogoods (round (* p2 mmm mmm)))
         (conflicts (make-array (list nnn nnn) :initial-element nil)))
          (do ((edges elist (cdr edges)))
              ((endp edges)
               (*csp-seconds*)           ; fix time stats
	      (funcall outputfunc elist nnn mmm p2 conflicts str ident 
generator-name)
              )
              ;(print (car edges))
	     (add-nogoods-fast
                   (car edges)
	          (funcall nogoods-generator (car edges) numnogoods allconflicts-vec
			   nnn mmm elist conflicts)
		  amatrix
                   conflicts)
		  )
    )
)

(defun colouring-nogoods (edge tmp1 tmp2 nnn mmm &rest forget)
   (declare (ignore edge forget tmp1 tmp2 nnn))
   (do ((i 0 (+ 1 i))
        (nogoods (list)
		(cons(list i i)
		      nogoods))
        )
       ((>= i mmm) nogoods)
       ))






;;; same-model-abcd
;; 	generates problems via models A to D, i.e assumes list of
;;      edges chosen and picks all conflicts for each constraint at once.
;;
;; given a constraint graph (list of edges), construct a
;; and output it in standard format
;;
;; elist     list of edges (*ordered* pairs)
;; nnn       number of nodes
;; mmm       domain size
;; ppp       pick (with repeats) round(ppp*mmm*nnn*(nnn-1)/2) nogoods
;; outfile   output file name
;;


(defun same-model-abcd  (elist nogoods-generator nnn mmm ppp outfile
&optional (sample 1)
                                (outputfunc #'output-csp-apes-str))
   (with-open-file (str outfile :direction :output)
     (format str "~%Problems ~A ~%" sample)
     (dotimes (i sample)
      (model-abcd-str (edges-normalise elist) nogoods-generator
		nnn mmm ppp str (+ i 1) "same-model-abcd" outputfunc))))



;;; add-nogoods-fast
;;  new in modelb1.lsp
;;  very fast because we assume all nogoods for same edge, nogoods just conflict pairs,
;;      and that there are no duplicate conflicts
;;
;; note that add-nogoods deleted, see modelf6.lsp for how it worked

(defun add-nogoods-fast (edge conflict-list amatrix conflicts)
  (let ((x (first edge))
        (y (second edge))
       )
       (if (zerop (aref amatrix x y))
           (error "Tried to add conflicts for edge but adjacency matrix
zero here")
           (setf (aref conflicts x y)
                 conflict-list))
       ))

(defun random-nogoods-modelb (edge numnogoods allconflicts-vec
				   nnn mmm elist conflicts
				   &optional (seed *random-state*)
                                    )
   (declare (ignore edge nnn mmm elist conflicts))
   (r-permute-vector-d allconflicts-vec :length numnogoods :seed seed)
)

(defun random-nogoods-modelb-flawless (edge numnogoods allconflicts-vec
				   nnn mmm elist conflicts
				   &optional (seed *random-state*))
  (if (> numnogoods (* mmm (1- mmm)))
      (error (format nil
	"random-nogoods-modelb-flawless: ~A too many nogoods for domain ~A~%"
         numnogoods mmm)))

  (let* ((enum (zero2n-1 mmm))
         (pi   (r-permute enum :seed seed))
         (goods (mapcar #'list enum pi)))

        (do ((gs goods (cdr gs))
             (flawless (copy-seq allconflicts-vec)
                       (delete (car gs) flawless :test #'equal))
			;; set-difference implementation dependent!
            )
            ((endp gs)
             (random-nogoods-modelb edge numnogoods flawless
		                   nnn mmm elist conflicts seed)
	))))


(defun random-nogood-modtoby (nnn mmm elist conflicts)
  (let ((edge (nth (random (length elist)) elist))
        (mx (random mmm))
        (my (random mmm)))
       (if (member (list mx my) (aref conflicts (first edge) (second edge))
                   :test 'equal)
           (random-nogood-modtoby nnn mmm elist conflicts)
           (list (first edge) (second edge) mx my)
       )
   )
)


(defun output-csp-apes (elist nnn mmm ppp conflicts str &optional (ident 1)
                                 (text "unknown") (file "csp"))
   (declare (ignore str))
   (with-open-file (stream
                    (concatenate 'string file (format nil "~4,'0D" ident))
                    :direction :output)
       (output-csp-apes-str elist nnn mmm ppp conflicts stream
			       ident text)))


(defun output-csp-apes-str (elist nnn mmm ppp conflicts str &optional (ident 1)
                                 (text "unknown") (file 'forget))
   (declare (ignore file))
   "output csp instance in APES group format"
     (progn
        (format str "~%BEGINCSP ~A ~%" ident)
(format str "COMMENT ~A ~A ~A ~A ~A~%~%" text nnn mmm ppp (length elist))
;; (format str "info( ~% modelf ~A ~A ~A ~A~%)~%~%" nnn mmm ppp (length 
elist))
        (format str "domains 1 (~%")
        (format str "(1 ~A ~A)~%~%" mmm (one2n mmm))
        (format str ")~%~%")
        (format str "variables ~A (~%" nnn)
        (do ((i 1 (1+ i)))
            ((> i nnn) (format str ")~%~%") )
            (format str "(~A 1)~%" i))
        (format str "constraints ~A (~%" (length elist))
        (do ((edges elist (cdr edges)))
            ((null edges) (format str ")~%~%") )
            (format str "~A~%" (output-edge (first edges))))
        (format str "conflicts ~A (~%" (length elist))
        (do ((edges elist (cdr edges)))
            ((null edges) (format str ")~%~%") )
            (progn
              (format str "(~A ~A (" (output-edge (first edges))
                                   (length (aref conflicts (first (first edges))
                                                           (second (first edges)))))
              (do ((nogoods (aref conflicts (first (first edges))
                                           (second (first edges))) (cdr nogoods)))
                  ((null nogoods) (format str "))~%") )
                  (format str "~A " (output-edge (first nogoods))))
            )
         )
         (format str "~%ENDCSP ~A ~%" ident)
    )
)


(defun output-edge (edge)
   (list (1+ (first edge)) (1+ (second edge)))
)

;; SAT output of CSP instances

;; e.g.
;; (model-abcd #'randgraph 20 10 0.5 #'random-nogoods-modelb-flawless 0.40 "tmpabc" 1 "3col" #'output-sat-csp)

(defvar example-call-1
	'(modelb-multi 50 50 1 (/ 2188.0 2500) "5050" 50
		'(output-sat-ac
		  output-sat-csp-gent
		  output-sat-csp-amo
		  output-sat-csp)
		'("ac" "gent" "amo" "direct"))
		)
(defvar example-call-1Test
	'(modelb-multi 50 50 1 (/ 2188.0 2500) "5050Test" 50
		'(
		  output-sat-csp-gent
		  )
		'("gent"))
		)
(defvar example-call-1Test-ac
	'(modelb-multi 50 50 1 (/ 2188.0 2500) "5050" 50
		'(
		  output-sat-ac
		  )
		'("ac"))
		)
(defvar example-call-2Test
	'(modelb-multi 150 50 (/ 500 75 149.0) (/ 2296.0 2500) "15050" 50
		'(output-sat-ac)
		'("ac"))
		)
(defvar example-call-4Test
     '(progn
	(modelb-multi 150 50 (/ 500 75 149.0) (/ 1250.0 2500) "15050under" 50
		'(output-sat-ac
		  )
		'("ac" ))
	(modelb-multi 150 50 (/ 500 75 149.0) (/ 2350.0 2500) "15050over" 50
		'(output-sat-ac
		  )
		'("ac" ))
		))
(defvar example-call-3
	'(modelb-multi 100 10 (/ 5 99) 0.55 "10010" 100
		'(output-sat-ac
		  output-sat-csp-gent
		  output-sat-csp-amo
		  output-sat-csp)
		'("ac" "gent" "amo" "direct"))
		)
(defvar example-call-3Test
	'(modelb-multi 100 10 (/ 5 99) 0.55 "10010" 100
		'(output-csp-apes
		  output-sat-csp-gent
		  output-sat-csp)
		'("csp" "gent" "direct"))
		)

(defun modelb-multi (n m p1 p2 dir sample &optional (funcs *output-functions*)
					            (names *output-prefixes*))
     (model-abcd #'randgraph-permutation n m p1 #'random-nogoods-modelb
                 p2 (concatenate 'string dir "/csp") sample "modelb"
                 (make-output dir funcs names)))

(defun modelb-sat-gent (n m p1 p2 &optional  (nonfile "tmpabc"))
     (model-abcd #'randgraph-permutation n m p1 #'random-nogoods-modelb p2
nonfile 1
                 "modelb" #'output-sat-csp-gent))
(defun modelb-ac (n m p1 p2 &optional  (nonfile "tmpabc"))
     (model-abcd #'randgraph-permutation n m p1 #'random-nogoods-modelb p2
nonfile 1
                 "modelb" #'output-sat-ac))
(defun modelb-sat-amo (n m p1 p2 &optional  (nonfile "tmpabc"))
     (model-abcd #'randgraph-permutation n m p1 #'random-nogoods-modelb p2
nonfile 1
                 "modelb" #'output-sat-csp-amo))
(defun modelb-sat (n m p1 p2 &optional  (nonfile "tmpabc"))
     (model-abcd #'randgraph-permutation n m p1 #'random-nogoods-modelb p2
nonfile 1
                 "modelb" #'output-sat-csp))

(defun modelb-flawless-sat (n m p1 p2 &optional  (nonfile "tmpabc"))
     (model-abcd #'randgraph-permutation n m p1
#'random-nogoods-modelb-flawless p2 nonfile 1
                 "modelb-flawless" #'output-sat-csp))

;;;; output functions

(defvar *output-functions*
         (list
           'output-csp-apes-str
           'output-sat-csp-gent
           'output-sat-csp
           'output-sat-csp-amo
           'output-sat-ac
           ))
(defvar *output-prefixes*
         '("csp" "gent" "direct" "amo" "ac"))

(defun make-output (dir &optional
                         (funcs *output-functions*)
                         (prefixes *output-prefixes*))
   #'(lambda (&rest args)
       (apply #'output-multi dir funcs prefixes args)))

(defun output-multi (dir output-funcs output-prefixes
                      elist nnn mmm ppp conflicts str &optional (ident 1)
                                 (text "unknown") (file ""))
   (defun output-one (func prefix)
     (funcall func elist nnn mmm ppp conflicts str ident text
              (concatenate 'string dir "/" prefix file)))
   (mapcar #'output-one output-funcs output-prefixes))

(defun output-sat-csp-gent (elist nnn mmm ppp conflicts str &optional (ident 1)
                                 (text "unknown") (file "tmpgent"))
   "Outputs SAT problem in Dimacs format in AC translation"
   (output-sat-general #'csp2sat-gent "csp2sat-gent"
                       elist nnn mmm ppp conflicts str ident text file))
(defun output-sat-ac (elist nnn mmm ppp conflicts str &optional (ident 1)
                                 (text "unknown") (file "tmpac"))
   "Outputs SAT problem in Dimacs format in AC translation"
   (output-sat-general #'ac2sat-gent "ac2sat-gent"
                       elist nnn mmm ppp conflicts str ident text file))

(defun output-sat-csp-amo (elist nnn mmm ppp conflicts str &optional (ident 1)
                                 (text "unknown") (file "tmpamo"))
   "Outputs SAT problem in Dimacs format in direct translation with at most
one clauses"
   (output-sat-general #'csp2sat-amo "csp2sat-amo"
                       elist nnn mmm ppp conflicts str ident text file))
(defun output-sat-csp (elist nnn mmm ppp conflicts str &optional (ident 1)
                                 (text "unknown") (file "tmpcsp"))
   "Outputs SAT problem in Dimacs format in direct translation"
   (output-sat-general #'csp2sat "csp2sat"
                       elist nnn mmm ppp conflicts str ident text file))

(defun output-sat-general (converter name
                            elist nnn mmm ppp conflicts str &optional (ident 1)
                                 (text "unknown") (file "tmptest"))
   "Outputs SAT problem in Dimacs format after converting problem"
   (declare (ignore str))
   (setf *sat-start-run-time* (get-internal-run-time)
         *sat-start-real-time* (get-internal-real-time))
   (let ((sat (funcall converter nnn mmm elist conflicts) ))
        (*sat-seconds*)

        (print-dimacs-simple
             (concatenate 'string file (format nil "~4,'0D" ident))
             sat
             :n (* nnn mmm)
             :comments
             (list (format nil "~A ~A n:~A m:~A p:~A c:~A"
                               ident text nnn mmm ppp (length elist))
                   (format nil "written by ~A by Ian Gent in Gnu CLisp" name)
                   (date-string)
                   (format nil "generation ~As run ~A real"
                           *csp-last-run-time* *csp-last-real-time*)
                   (format nil "conversion ~As run ~A real"
                           *sat-last-run-time* *sat-last-real-time*)
                   )
             ))
   )


(defun csp2sat-gent (nnn mmm elist conflicts)
     "Constructs Ian Gent's encoding of Arc Consistency into SAT"
     (nconc (at-most-one-clauses nnn mmm)
            (ac2sat-gent nnn mmm elist conflicts)))

;;; ac2sat-gent
;;
;; assumes a fixed domain size m
;; uses a 2d array cmatrix for "conflict matrix"
;;      to avoid zeroing this a trick is used
;;      the constraint count is incremented each time,
;;          and we change the array element of each conflict to this value
;;          when we find it in the conflict list
;;      to test for membership of conflict list, we see if the array element
;;          is equal to the constraint count

(defun ac2sat-gent (nnn mmm elist conflicts)
     "Constructs Ian Gent's encoding of Arc Consistency into SAT"
    (do ((edges elist (cdr edges))
         (cmatrix (make-array (list mmm mmm) :element-type 'integer
                                             :initial-element 0))
         (constraint-count 1 (1+ constraint-count))
         (clauses (exists-clauses nnn mmm)
                  (nconc
                       (support-clauses
                          nnn
                          mmm
                          (first (first edges))
                          (second (first edges))
                          (aref conflicts (first (first edges))
                                          (second (first edges)))
                          cmatrix constraint-count)
                        clauses))
         )
        ((null edges)
         clauses)
        )
    )


(defun support-clauses-aux (n m i1 i2 cmatrix constraint-count)
             ;; recall that conflicts are from 0 to n-1
   (defun support-clause-row (j)
     (do ((k 0 (1+ k))
          (lits '()))
         ((= k m)
          (cons (- (ij-var n m i1 j)) lits)
          )
         (if (not (= (aref cmatrix j k) constraint-count))
             (push (ij-var n m i2 k) lits)))
     )
   (defun support-clause-col (k)
     (do ((j 0 (1+ j))
          (lits '()))
         ((= j m)
          (cons (- (ij-var n m i2 k)) lits)
          )
         (if (not (= (aref cmatrix j k) constraint-count))
             (push (ij-var n m i1 j) lits)))
     )
   (nconc
        (do ((j 0 (1+ j))
             (clauses '()))
            ((= j m)
             clauses)
            (let ((clause (support-clause-row j)))
                     ;; no need for clause if all values support
                     ;; the length of the clause would then be m+1
              (if (<= (length clause) m)
                  (push clause clauses)))
            )
        (do ((k 0 (1+ k))
             (clauses '()))
            ((= k m)
             clauses)
            (let ((clause (support-clause-col k)))
                     ;; no need for clause if all values support
                     ;; the length of the clause would then be m+1
              (if (<= (length clause) m)
                  (push clause clauses)))
            )
        )
   )

(defun support-clauses (n m i1 i2 conflicts cmatrix constraint-count)
        (do ((cs conflicts (cdr cs)))
            ((endp cs)
             (support-clauses-aux n m i1 i2 cmatrix constraint-count))

            (setf (aref cmatrix (first (car cs)) (second (car cs)))
                  constraint-count)))

;;; csp2sat
;;  simple direct encoding of csp into sat

(defun csp2sat-amo (nnn mmm elist conflicts)
     "Constructs Direct encoding of CSP into SAT including at most one clauses"
     (nconc (at-most-one-clauses nnn mmm)
            (csp2sat nnn mmm elist conflicts)))

(defun csp2sat (nnn mmm elist conflicts)
    (do ((edges elist (cdr edges))
         (clauses (exists-clauses nnn mmm)
                  (nconc
                       (conflicts-clauses
                          nnn
                          mmm
                          (first (first edges))
                          (second (first edges))
                          (aref conflicts (first (first edges))
                                          (second (first edges))))
                        clauses))
         )
        ((null edges)
         clauses)
        )
)

(defun at-most-one-clauses-aux (n m i)
   (let ((res '()))
        (dotimes (j m)
           (dotimes (k j)
                    (push (list (- (ij-var n m i k)) (- (ij-var n m i j)))
                          res)
                    ))
        res))

(defun at-most-one-clauses (n m)
	(do ((i 0 (1+ i))
              (res nil (nconc (at-most-one-clauses-aux n m i) res))
	    )
	    ((>= i n)
	     res))
)

  ;; following based on csp2sat.lsp
  ;; don't remember writing a lot of this stuff so maybe somebody else did?

;;; simple csp2sat generator

;;; for the Clark-Grant format
;;; but assuming fixed size domains m

(defun ij-var (n m i j)
    (declare (ignore n))
	(1+ (+ (* i m) j))
)

(defun exists-clause (n m i)
	(do ((j 0 (1+ j))
              (res nil (cons (ij-var n m i j) res))
             )
             ((>= j m)
              res)
         ))

(defun exists-clauses (n m)
	(do ((i 0 (1+ i))
              (res nil (cons (exists-clause n m i) res))
	    )
	    ((>= i n)
	     res))
)


(defun conflict-clause (n m i1 j1 i2 j2)
	(list (- (ij-var n m i1 j1))
               (- (ij-var n m i2 j2))
	))

(defun conflicts-clauses (n m i1 i2 conflicts)
	(mapcar
		#'(lambda (cf)
			(conflict-clause n m i1 (car cf) i2 (second cf)))
		conflicts))

; (defun satvar2val (m var)
	; (list (+ 1 (floor (- var 1) m))
               ; (mod var m)))


;; construct the graph of a clique for nnn nodes numbered 0... n-1


(defun cliquegraph (edges nnn &rest forget)
   (declare (ignore edges forget))
  (do ((i 0 (+ i 1))
       (edges (list))
      )
      ((> i (- nnn 1))
       edges)
      (do ((j (+ i 1) (+ j 1)))
          ((> j (- nnn 1)))
          ;(print (format nil "e ~A ~A" i j))
          (setq edges (insert-edge (list i j) edges)
      ))))


(defun randgraph-permutation (eee nnn &optional (seed *random-state*))

  (let ((edges (cliquegraph eee nnn)))  ; should be normalised edges

       (r-permute edges :length eee :seed seed)))

;; construct a random graph with eee edges and nnn nodes
;; duplicate edges not allowed

(defun randgraph (eee nnn)
  (do ((edges nil (insert-edge (randedge nnn) edges)))
      ((= (length edges) eee) edges)
  )
)

(defun randedge (nnn)
  (let ((i (random nnn))
        (j (random nnn)))
       (if (= i j)
           (randedge nnn)
           (list (min i j) (max i j))
       )
   )
)

(defun insert-edge (edge edges)
  (if (null edges) (list edge)
    (if (< (first edge) (first (first edges)))
        (cons edge edges)
        (if (= (first edge) (first (first edges)))
            (if (< (second edge) (second (first edges)))
                (cons edge edges)
                (if (= (second edge) (second (first edges)))
                    edges
                    (cons (first edges) (insert-edge edge (cdr edges)))))
            (cons (first edges) (insert-edge edge (cdr edges)))
        )
     )
  )
)

;; construct a ring lattice with nnn nodes, each connected
;; to its kkk nearest neighbours (kkk assumed to be
;; even)

;; graphs represented by list of edges, each an ordered
;; list of nodes, nodes are integers in [0,nnn)

(defun lattice (nnn kkk)
   (do ((i 0 (1+ i))
        (edges nil (do* ((j i (mod-plus j 1 nnn))
                        (ans edges (if (= i j) edges
                                       (cons (ordered-list i j) ans))))
                        ((= j (mod-plus i (/ kkk 2) nnn)) ans))))
       ((= i nnn) edges)
   )
)

;; rewires edges in a ring lattice with probability ppp
;; according to model of Watts and Strogatz

(defun rewire (nnn kkk ppp)
  (let ((amatrix (elist2amatrix (lattice nnn kkk) nnn)))
       (do ((i 1 (1+ i)))
           ((> i (/ kkk 2))
                 (amatrix2elist amatrix nnn))
           (do ((j 0 (1+ j)))
               ((= j nnn) )
               (if (and (not (zerop (aref amatrix j (mod-plus i j nnn))))
                        (< (random 1.0) ppp))
                   (let* ((r (random (1- nnn)))
                          (k (if (>= r j) (1+ r) r)))
                        (if (zerop (aref amatrix j k))
                            (progn (setf (aref amatrix j (mod-plus i j nnn)) 0)
                                   (setf (aref amatrix (mod-plus i j nnn) j) 0)
                                   (setf (aref amatrix j k) 1)
                                   (setf (aref amatrix k j) 1)))))

           )
       )
  )
)


(defun mod-minus (i j n)
  (mod (- i j) n))

(defun mod-plus (i j n)
  (mod (+ i j) n))

(defun ordered-list (i j)
  (if (< i j) (list i j)
              (list j i)))


(defun elist2amatrix (elist nnn)
  (let ((amatrix (make-array (list nnn nnn) :initial-element 0
:element-type 'bit)))
  (do ((edges elist (cdr edges)))
       ((null edges) amatrix)
      (progn
         (setf (aref amatrix (first (first edges))
                             (second (first edges))) 1)
         (setf (aref amatrix (second (first edges))
                             (first (first edges))) 1))
   ))
)


(defun amatrix2elist (amatrix nnn)
  (do ((i 0 (1+ i))
       (elist nil (do ((j i (1+ j))
                       (ans elist (if (zerop (aref amatrix i j))
                                      ans
                                      (cons (list i j) ans))))
                      ((= j nnn) ans))))
      ((= i nnn) elist)
  )
)

;; draw a grap using pic

(defun graph2pic (elist nnn file)
   (with-open-file (str file :direction :output)
     (progn
        (format str ".PS~%.ps 11~%")
        (do ((i 0 (1+ i)))
            ((= i nnn) )
            (format str "circle at ~A,~A rad 0.02~%"
                (coord2pic (x-coord i nnn))
                (coord2pic (y-coord i nnn))))
        (do ((edges elist (cdr edges)))
            ((null edges) )
            (format str "line from ~A,~A to ~A,~A~%"
                (coord2pic (x-coord (first (car edges)) nnn))
                (coord2pic (y-coord (first (car edges)) nnn))
                (coord2pic (x-coord (second (car edges)) nnn))
                (coord2pic (y-coord (second (car edges)) nnn))))
        (format str ".PE~%")
     )
   )
)


(defun x-coord (i nnn)
   (+ 1/2 (* 1/2 (cos (/ (* i 2 pi) nnn))))
)

(defun y-coord (i nnn)
   (+ 1/2 (* 1/2 (sin (/ (* i 2 pi) nnn)))))

(defun coord2pic (coord)
   (float (* 3 (/ (round (* 10000 coord)) 10000))))


;; construct constraint graph of nnn by nnn quasigroup

(defun qgroup2elist (nnn)
   (do ((i 0 (1+ i))
        (elist nil (row-all-diff i nnn
                      (col-all-diff i nnn
                           elist))))
       ((= i nnn) elist))
)

(defun row-all-diff (i nnn acc)
   (do ((j 0 (1+ j))
        (ans acc (do ((k (1+ j) (1+ k))
                      (ans2 ans (cons (qg-edge i j i k nnn) ans2)))
                     ((>= k nnn) ans2))))
       ((= j nnn) ans)))

(defun col-all-diff (i nnn acc)
   (do ((j 0 (1+ j))
        (ans acc (do ((k (1+ j) (1+ k))
                      (ans2 ans (cons (qg-edge j i k i nnn) ans2)))
                     ((>= k nnn) ans2))))
       ((= j nnn) ans)))


(defun qg-edge (x1 y1 x2 y2 nnn)
   (list (+ (* x1 nnn) y1)
         (+ (* x2 nnn) y2))
)

;; read in a DIMACS graph

(defun read-graph (file)
   (let ((graph nil))
   (with-open-file (stream file :direction :input)
      (loop for data = (read stream nil 'eof)
                  until (eq data 'eof)
        if T do
        (progn
          (if (equal data 'E)
              (setf graph (cons (list (1- (read stream)) (1- (read
stream))) graph)))

        )
      )
   )
   graph)
)


;; construct Hogg's clustered graphs


(defun clustered (nnn eee ppp)
   (if (<= ppp 1)
   (do ((elist nil elist))
       ((= (length elist) eee) elist)
       (let* ((iii (random nnn))
              (jjj (random nnn))
              (edge (ordered-list iii jjj)))
            (if (and (not (= iii jjj))
                     (<= (random 1.0)
                         (expt ppp (ultrametric iii jjj)))
                     (not (member edge elist :test 'equal)))
                (setf elist (cons edge elist))))
   )
   (let ((rrr (float (* 2 (floor (log nnn 2))))))
   (do ((elist nil elist))
       ((= (length elist) eee) elist)
       (let* ((iii (random nnn))
              (jjj (random nnn))
              (edge (ordered-list iii jjj)))
            (if (and (<= (random rrr)
                         (expt ppp (ultrametric iii jjj)))
                     (not (member edge elist :test 'equal)))
                (setf elist (cons edge elist))))
   ))
  )
)

(defun up-tree (nnn)
   (if (zerop nnn) nnn
       (1- (floor (/ (1+ nnn) 2))))
)

(defun ultrametric (nnn mmm)
   (if (= nnn mmm) 0
       (if (> nnn mmm)
           (1+ (ultrametric (up-tree nnn) mmm))
           (1+ (ultrametric nnn (up-tree mmm)))
       )
   )
)

(defun all-conflicts (mmm)
   (cross-product (zero2n-1 mmm) (zero2n-1 mmm)))

(defun cross-product (l1 l2)
  (do ((res nil)
       (lone l1 (cdr lone))
      )
      ((endp lone)
       res)

      (do ((ltwo l2 (cdr ltwo)))
	((endp ltwo))
          (push (list (car lone) (car ltwo)) res)
	)))

(defun zero2n-1 (nnn)
  (mapcar #'1- (one2n nnn)))

(defun one2n (nnn)
  (reverse (n2one nnn))
)

(defun n2one (nnn)
   (if (zerop nnn) nil
       (cons nnn (n2one (1- nnn)))
   )
)

;; much more efficient version of r-permute than used previously!
;;  make it a vector for random access,
;;  then choose a random element 1..n, and swap it with the last element,
;;      then choose a random element from 1..n-1, etc.

(defun r-permute (list &key (seed *random-state*) (length nil)
                        &aux (lengthlist (length list))
                             (vector (make-array lengthlist
:initial-contents list))
                             )

   (cond ((and (numberp length) (>= lengthlist length 0))
          (r-permute-aux vector length lengthlist seed))
         (t
          (r-permute-aux vector lengthlist lengthlist seed))
         ))


(defun r-permute-vector-d (vector &key (seed *random-state*) (length nil)
                                   &aux (lengthlist (length vector)))
       "Destructively permutes input vector, returning list"
   (cond ((and (numberp length) (>= lengthlist length 0))
          (r-permute-swap-aux vector length lengthlist seed))
         (t
          (r-permute-swap-aux vector lengthlist lengthlist seed))
         ))

;; vec will get mangled
;; vec may not contain same set of elements as before call

(defun r-permute-aux (vec length_output length_vector seed)
    (do ((n length_vector (1- n))
         (end (- length_vector length_output))
         r
         (output '())
        )
        ((<= n end) output)

        (setf r (random n seed))
        (push (aref vec r) output)
        (setf (aref vec r) (aref vec (1- n)))))

;; vec will get mangled
;; is be reusable as permutation as  we swap instead of overwriting

(defun r-permute-swap-aux (vec length_output length_vector seed)
    (do ((n length_vector (1- n))
         (end (- length_vector length_output))
         r
         v
         (output '())
        )
        ((<= n end)
                ;(if (not (= length_vector (length (remove-duplicates vec
:test #'equal))))
                ;    (error "oops a doops")
                ;    (print nil))
         output)

        (setf r (random n seed))
        (setf v (aref vec r))
        (push v output)
        (setf (aref vec r) (aref vec (1- n))
              (aref vec (1- n)) v))
    )

;;; edge-normalise

(defun edge-normalise (edge)
   (list (min (first edge) (second edge))
         (max (first edge) (second edge))))

(defun edges-normalise (edges) (mapcar #'edge-normalise edges))

;; print out in dimacs format
;; originally from formats6.lsp


(defun print-dimacs-simple (file problem &key (n (length (variables problem)))
                                        (comments ""))
   "Assume formula of form ((1 -18 9  ....) ...)"
   (with-open-file (s file :direction :output)
     (if (listp comments)
         (dolist (comment comments)
                 (format s "c ~A~%" comment))
         (format s "c ~A~%" comments))
     (format s "p cnf ~A ~A ~%"
             n
             (length problem))
     (mapcar #'(lambda (x)
              (dolist (i x (format s "0~%") )
                      (if (listp i)
                             (format s "-~A " (second i))
                             (format s "~A " i))
                     )
              (finish-output s)  ;; attempt to correct bugged output
                  )
             problem)
))

(defun variables (sigma)
    (remove-duplicates
       (cond ((null sigma) sigma)
             ((equal sigma t) nil)
             ((atom sigma) (list sigma))
             (t (mapcan `variables (cdr sigma))))))


;;; timing stuff

(defun *csp-seconds* ()
   (setf *csp-last-run-time*
         (float  (/ (- (get-internal-run-time) *csp-start-run-time*)
                           internal-time-units-per-second))
         *csp-last-real-time*
         (float  (/ (- (get-internal-real-time) *csp-start-real-time*)
                           internal-time-units-per-second)))
   (list *csp-last-run-time* *csp-last-real-time*))



(defun *sat-seconds* ()
   (setf *sat-last-run-time*
         (float  (/ (- (get-internal-run-time) *sat-start-run-time*)
                           internal-time-units-per-second))
         *sat-last-real-time*
         (float  (/ (- (get-internal-real-time) *sat-start-real-time*)
                           internal-time-units-per-second)))
   (list *sat-last-run-time* *sat-last-run-time*))


(defun date-string (&optional (timelist
                                 (multiple-value-list (get-decoded-time))))
   (format nil "~A/~A/~A ~2,'0D:~2,'0D:~2,'0D"
           (sixth timelist) (fifth timelist) (fourth timelist)
           (third timelist) (second timelist) (first timelist)))

(defun make (&optional (files '("modelb1Test")))
   (dolist (i files)
           (compile-file i)(load i)))