;; hacked for scaling quantum majority on problem, using a NUMQUBITS push constant
;; turned off gate literalization, ephem rand unitary, since doesn't work
;;  with multiple sizes

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qgame-pushgp.lisp
;; code integrating pushgp and qgame
;;
;; c) 2001-2003, Lee Spector (lspector@hampshire.edu)

;; first do with just direct construction of the qprog
;; then add matrix type (& thereby storage), multiplication, expansion
;;   (must work out details of what expands when)
;; maybe someday add qgame-expression type so programs can be manipulated
;;    mid- and post-construction


;; removed communication (alice/bob) stuff

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; cluster stuff is defined in pushgp.lisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; push parameters

;; will come from .pst file


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pushgp parameters

(setq *max-new-points-in-mutants* 20)
(setq *population-size* 5000)
(setq *tournament-size* 7)
(setq *max-generations* 1000)
(setq *number-of-fitness-cases* 1) ;; always 1
(setq *halting-fitness* 0)
(setq *mutation-probability* 0.45)
(setq *crossover-probability* 0.45)
(setq *immigration-probability* 0.005)
(setq *re-evaluate-clones* nil)
(setq *mutation-operators* 
      (list 
       ;'standard 
       'fair 
       'perturb
       'add
       'remove
       ))
(setq *crossover-operators* 
      (list 
       ;'standard 
       'fair 
       ;'uniform
       ))
(setq *pushgp-output-path* 
  (concatenate 'string *out-dir* "pushgp-output" *host-extension*))
(setq *produce-chart-output* nil)
(setq *size-pressure* 1)
(setq *ideal-size* 50)
(setq *apply-size-pressure-to-cloning* nil)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qgame/qgame-pushgp parameters and globals
;; (no longer in quantum simulator -- defined here for this problem only)

;; OR / XOR: FOR MAJON THESE WILL BE RESET IN THE FITNESS FUNCTION
(defparameter *number-of-qubits* 2)
(defparameter *all-qubits* (list 0 1))
(defparameter *measurement-qubits* (list 1))
(defparameter *oracle-size* 2)
(defparameter *max-oracle-calls* 1)

;; AND/OR
;(defparameter *number-of-qubits* 3)
;(defparameter *all-qubits* (list 0 1 2))
;(defparameter *measurement-qubits* (list 2))
;(defparameter *oracle-size* 3)
;(defparameter *max-oracle-calls* 1)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; hacked operators


(defun remove-everywhere (item list)
  (if (listp list) 
    (remove item (mapcar #'(lambda (i) (remove-everywhere item i)) list))
    list))


(defun mutate-program (p)
  "Returns a mutated version of the program p."
  (let ((op (random-element *mutation-operators*)))
    (case op
      (standard
       (let ((new-program (insert-code-at-point
                           p 
                           (randint (count-points p))
                           (random-code *max-new-points-in-mutants*))))
         (if (> (count-points new-program)
                *Max-Points-In-Program*)
           p
           new-program)))
      (fair
       (let* ((mutate-point (randint (count-points p)))
              (new-program (insert-code-at-point
                            p 
                            mutate-point
                            (random-code-fair 
                             (count-points 
                              (code-at-point p mutate-point))))))
         (if (> (count-points new-program)
                *Max-Points-In-Program*)
           p
           new-program)))
      (perturb
       (dirty-copy p *dirty-mutation-denominator*))
      (add 
       (let* ((pt (randint (count-points p)))
              (old-frag (code-at-point p pt))
              (new-frag  (random-code *max-new-points-in-mutants*))
              (new-program (insert-code-at-point
                            p 
                            pt
                            (if (zerop (randint 2))
                              (list old-frag new-frag)
                              (list new-frag old-frag)))))
         (if (> (count-points new-program)
                *Max-Points-In-Program*)
           p
           new-program)))
      (remove
       (let* ((pt (randint (count-points p)))
              (unique (gensym))
              (new-program
               (remove-everywhere 
                unique
                (insert-code-at-point p pt unique))))
         (if (> (count-points new-program)
                *Max-Points-In-Program*)
           p
           new-program)))
      )))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fitness cases

;; OR
;; a case is (tt-right-column answer)
;(defparameter *fitness-cases* 
;  '(((0 0) 0)
;    ((0 1) 1)
;    ((1 0) 1)
;    ((1 1) 1)))

;; XOR
;; a case is (tt-right-column answer)
;(defparameter *fitness-cases* 
;  '(((0 0) 0)
;    ((0 1) 1)
;    ((1 0) 1)
;    ((1 1) 0)))

;; ODDLOC
;; a case is (oracle-size subcases) where a subcase is (tt-right-column answer)
#|(setq *number-of-fitness-cases* 3)
(defparameter *fitness-cases*
  '((2 
     (((1 0) 0)
      ((0 1) 1)))
    (3 
     (((1 0 0 0) 0)
      ((0 1 0 0) 1)
      ((0 0 1 0) 0)
      ((0 0 0 1) 1)))
    (4 
     (((1 0 0 0 0 0 0 0) 0)
      ((0 1 0 0 0 0 0 0) 1)
      ((0 0 1 0 0 0 0 0) 0)
      ((0 0 0 1 0 0 0 0) 1)
      ((0 0 0 0 1 0 0 0) 0)
      ((0 0 0 0 0 1 0 0) 1)
      ((0 0 0 0 0 0 1 0) 0)
      ((0 0 0 0 0 0 0 1) 1)))
    ))|#


;; all of the following is for AND/OR
#|
(defun tnil->10 (tnil)
  "Returns 1 or 0 given t or nil."
  (if tnil 1 0))

(defun first-half (list)
  "Returns the first half of the given list."
  (butlast list (truncate (length list) 2)))

(defun second-half (list)
  "Returns the second half of the given list."
  (nthcdr (truncate (length list) 2) list))

(defun and-or (tt &optional (this-level :and))
  "always AND at root"
  (if (null (rest tt))
    (tnil->10 (= 1 (first tt)))
    (case this-level
      (:and (tnil->10
             (and (= 1 (and-or (first-half tt) :or))
                  (= 1 (and-or (second-half tt) :or)))))
      (:or (tnil->10
            (or (= 1 (and-or (first-half tt) :and))
                (= 1 (and-or (second-half tt) :and))))))))

(defun binary-expansion (int numbits)
  "returns a list of numbits 1s and 0s corresponding to the
binary representation of int."
  (let ((result nil))
    (dotimes (bitposition numbits)
      (push (if (logbitp bitposition int) 1 0) result))
    result))

(defun all-cases (num-qubits)
  (let* ((cases nil)
         (tt-size (expt 2 num-qubits))
         (num-cases (expt 2 tt-size)))
    (dotimes (input-number num-cases)
      (let ((truth-table (binary-expansion input-number tt-size)))
        (push (list truth-table (and-or truth-table))
              cases)))
    (reverse cases)))

(defparameter *fitness-cases* (all-cases 2))

|#


;; all of the following is for MAJON

(defun tnil->10 (tnil)
  "Returns 1 or 0 given t or nil."
  (if tnil 1 0))

(defun majon (tt)
  (tnil->10 (> (count 1 tt) (count 0 tt))))

(defun binary-expansion (int numbits)
  "returns a list of numbits 1s and 0s corresponding to the
binary representation of int."
  (let ((result nil))
    (dotimes (bitposition numbits)
      (push (if (logbitp bitposition int) 1 0) result))
    result))

(defun all-cases (num-qubits)
  (let* ((cases nil)
         (tt-size (expt 2 num-qubits))
         (num-cases (expt 2 tt-size)))
    (dotimes (input-number num-cases)
      (let ((truth-table (binary-expansion input-number tt-size)))
        (push (list truth-table (majon truth-table))
              cases)))
    (remove-if #'(lambda (case) (= (count 0 (first case))
                                   (count 1 (first case))))
               (reverse cases))))

(defparameter *fitness-cases* 
  (list (list 2 (all-cases 1))
        (list 3 (all-cases 2))
        (list 4 (all-cases 3))))
  
(setq *number-of-fitness-cases* (length *fitness-cases*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utilities


(defun rationalize-angle (float-angle)
  "Returns a string describing an angle in human-readable form. This
will consist of a floating-point representation followed by square brackets
that will include a ratio-of-pi expression if one can be formed easily;
otherwise the square brackets will be empty."
  (let ((string "?"))
    (do ((epsilon 0.01)
         (n -15 (+ n 1)))
        ((> n 15) (format nil "{~,5F [~A]}" float-angle string))
      (do ((m 1 (+ m 1)))
          ((> m 16))
        (when (string-equal string "?")
          (let ((angle (/ (* n pi) m)))
            (when (< (- angle epsilon) float-angle (+ angle epsilon))
              (setq string
                    (format nil "~Api~A"
                            (if (= n 1) "" n)
                            (if (= m 1) "" (format nil "/~A" m)))))))))))

(defun printprog (program)
  "Prints a human-readable version of program with all floating-point
numbers rationalized."
  (dolist (instr program)
    (format t "~%")
    (dolist (atom instr)
      (format t "~A "
              (if (floatp atom)
                (rationalize-angle atom)
                atom))))
  (values))

(defun firstn (n list)
  (subseq list 0 n))

(defun one-of (list)
  (nth (randint (length list)) list))

(defun consr (thing list)
  (append list (list thing)))

(defun legitimize-single-qubit (qubit)
  (mod qubit *number-of-qubits*))

(defun legitimize-qubits (qubits)
  (let ((new-qubits nil))
    (dolist (q qubits)
      (let ((wrapped (mod q *number-of-qubits*)))
        (do ()
            ((not (member wrapped new-qubits)))
          (setq wrapped (mod (1+ wrapped) *number-of-qubits*)))
        (push wrapped new-qubits)))
    (reverse new-qubits)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the qgate type

;; stack holds structures containing fully expanded unitary matrices
;; with composition histories

;; most qgate instructions expand and push a matrix

;; GATE instruction adds matrix to qgame program under construction

;; normal stack manipulation for matrices plus COMPOSE, TRANSPOSE

;; oracle, limited-oracle, measure, end, and halt go directly to
;; qgame program under construction

;; matrix literalization


;; we have a unitary structure to hold matrix and composition history
;; this is the type that goes on the qgate stack
(defstruct unitary matrix history)

(defun unitary-from-gate-forms (unitary-qgame-program) 
  "Returns a unitary structure for the provided unitary-qgame-program,
which is assumed to include only unitary operations (including matrix-gate
forms), onto the qgate stack. If the construction of the unitary matrix
fails (for example because it would be nested too deeply, or because
round-off errors cause a unitarity check to fail) then this returns 'FAIL."
  (let ((compressed (thoroughly-compress-gates unitary-qgame-program)))
    (if (null (rest compressed)) ; compressed okay
      (make-unitary :matrix (second (first compressed))
                    :history (third (first compressed)))
      'FAIL)))

(defparameter *unitary-literals* nil "For matrix literalization.")

(defun ephemeral-random-unitary () 
  (or (random-element *unitary-literals*)
      ;; identity if none
      (make-unitary :matrix (expand-matrix #2A((1 0) (0 1)) '(0))
                    :history '(IDENTITY))))

(let (qgame-program-under-construction)
  (defun init-qprog ()
    (setq qgame-program-under-construction nil))
  (defun add-qprog (qgame-instruction)
    (setq qgame-program-under-construction
          (consr qgame-instruction 
                 qgame-program-under-construction)))
  (defun qprog ()
    qgame-program-under-construction))

(defpushtype qgate
  :templates (dup pop swap = 
                  yank yankdup shove stackdepth
                  ;rand
                  set get
                  
                  compose transpose
                  gate
                  oracle limited-oracle
                  hadamard u-theta srn qnot cnot swp cphase u2  
                  ;smolin bernstein bs-theta supersmolin 
                  halt measure end)
  :literal-recognizer nil ;#'unitary-p ;***
  :erc-generator nil ;#'ephemeral-random-unitary ;****
  :default (make-unitary :matrix (expand-matrix #2A((1 0) (0 1)) '(0))
                         :history '(IDENTITY))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; method implementations

(deftemplate compose
  (let ((stack-contents (pushtype-stack type)))
    (unless (null (rest stack-contents))
      (let* ((top (first stack-contents))
             (next (second stack-contents))
             (pgm (list (list 'matrix-gate
                              (unitary-matrix top)
                              (unitary-history top))
                        (list 'matrix-gate
                              (unitary-matrix next)
                              (unitary-history next))))
             (result (unitary-from-gate-forms pgm)))
        (unless (eq result 'FAIL)
          (setf (pushtype-stack type)
                (cons result
                      (rest (rest stack-contents)))))))))

(defun transpose-matrix (m)
  (let* ((dim (first (array-dimensions m)))
         (result (make-array (list dim dim))))
    (dotimes (i dim)
      (dotimes (j dim)
        (setf (aref result i j)
              (aref m j i))))
    result))

(deftemplate transpose
  (let ((stack-contents (pushtype-stack type)))
    (unless (null stack-contents)
      (setf (pushtype-stack type)
            (cons (make-unitary 
                   :matrix (transpose-matrix 
                            (unitary-matrix (first stack-contents)))
                   :history (list 'TRANSPOSED
                                  (unitary-history (first stack-contents))))
                  (rest stack-contents))))))

(deftemplate gate
  (let ((stack-contents (pushtype-stack type)))
    (unless (null stack-contents)
      (add-qprog (list 'matrix-gate
                       (unitary-matrix (first stack-contents))
                       (unitary-history (first stack-contents))))
      (setf (pushtype-stack type)
            (rest stack-contents)))))
  
(deftemplate oracle
  (let* ((int (find-pushtype 'integer))
         (stack (pushtype-stack int)))
    (unless (null (nthcdr (- *oracle-size* 1) stack))
      (add-qprog (append (list 'oracle 'ORACLE-TT)
                         (legitimize-qubits 
                          (reverse (firstn *oracle-size* stack)))))
      (setf (pushtype-stack int) (nthcdr *oracle-size* (pushtype-stack int))))))

(deftemplate limited-oracle 
  (let* ((int (find-pushtype 'integer))
         (stack (pushtype-stack int)))
    (unless (null (nthcdr (- *oracle-size* 1) stack))
      (add-qprog (append (list 'limited-oracle *max-oracle-calls* 'ORACLE-TT)
                         (legitimize-qubits 
                          (reverse (firstn *oracle-size* stack)))))
      (setf (pushtype-stack int) (nthcdr *oracle-size* (pushtype-stack int))))))

(deftemplate hadamard
  (let* ((int (find-pushtype 'integer))
         (stack (pushtype-stack int)))
    (unless (null stack)
      (let ((pgm (list (list 'hadamard 
                             (legitimize-single-qubit (first stack))))))
        (setf (pushtype-stack type)
              (cons (unitary-from-gate-forms pgm)
                    (pushtype-stack type))))
      (setf (pushtype-stack int) (rest stack)))))

(defun mod2pi (n) (mod n (* 2 pi)))

(deftemplate u-theta 
  (let* ((int (find-pushtype 'integer))
         (float (find-pushtype 'float)))
    (unless (or (null (pushtype-stack int))
                (null (pushtype-stack float)))
      (let ((pgm (list (list 'u-theta 
                             (legitimize-single-qubit (first (pushtype-stack int)))
                             (mod2pi (first (pushtype-stack float)))))))
        (setf (pushtype-stack type)
              (cons (unitary-from-gate-forms pgm)
                    (pushtype-stack type))))
      (setf (pushtype-stack int) (rest (pushtype-stack int)))
      (setf (pushtype-stack float) (rest (pushtype-stack float))))))

(deftemplate srn 
  (let* ((int (find-pushtype 'integer))
         (stack (pushtype-stack int)))
    (unless (null stack)
      (let ((pgm (list (list 'srn 
                             (legitimize-single-qubit (first stack))))))
        (setf (pushtype-stack type)
              (cons (unitary-from-gate-forms pgm)
                    (pushtype-stack type))))
      (setf (pushtype-stack int) (rest (pushtype-stack int))))))

(deftemplate qnot
  (let* ((int (find-pushtype 'integer))
         (stack (pushtype-stack int)))
    (unless (null stack)
      (let ((pgm (list (list 'qnot 
                             (legitimize-single-qubit (first stack))))))
        (setf (pushtype-stack type)
              (cons (unitary-from-gate-forms pgm)
                    (pushtype-stack type))))
      (setf (pushtype-stack int) (rest (pushtype-stack int))))))

(deftemplate cnot 
  (let* ((int (find-pushtype 'integer))
         (stack (pushtype-stack int)))
    (unless (null (rest stack))
      (let ((pgm (list (cons 'cnot 
                             (legitimize-qubits
                              (list (second stack) (first stack)))))))
        (setf (pushtype-stack type)
              (cons (unitary-from-gate-forms pgm)
                    (pushtype-stack type))))
      (setf (pushtype-stack int) (rest (rest (pushtype-stack int)))))))

(deftemplate swp 
  (let* ((int (find-pushtype 'integer))
         (stack (pushtype-stack int)))
    (unless (null (rest stack))
      (let ((pgm (list (cons 'swap 
                             (legitimize-qubits 
                              (list (second stack) (first stack)))))))
        (setf (pushtype-stack type)
              (cons (unitary-from-gate-forms pgm)
                    (pushtype-stack type))))
      (setf (pushtype-stack int) (rest (rest (pushtype-stack int)))))))

(deftemplate cphase 
  (let* ((int (find-pushtype 'integer))
         (float (find-pushtype 'float)))
    (unless (or (null (rest (pushtype-stack int)))
                (null (pushtype-stack float)))
      (let ((pgm (list (cons 'cphase 
                             (append
                              (legitimize-qubits 
                               (list (second (pushtype-stack int)) 
                                     (first (pushtype-stack int))))
                              (list (mod2pi (first (pushtype-stack float)))))))))
        (setf (pushtype-stack type)
              (cons (unitary-from-gate-forms pgm)
                    (pushtype-stack type))))
      (setf (pushtype-stack int) (rest (rest (pushtype-stack int))))
      (setf (pushtype-stack float) (rest (pushtype-stack float))))))

(deftemplate u2
  (let* ((int (find-pushtype 'integer))
         (float (find-pushtype 'float)))
    (unless (or (null (pushtype-stack int))
                (null (nthcdr 3 (pushtype-stack float))))
      (let ((pgm (list (cons 'u2 
                             (cons (legitimize-single-qubit 
                                    (first (pushtype-stack int)))
                                   (list (mod2pi (fourth (pushtype-stack float)))
                                         (mod2pi (third (pushtype-stack float)))
                                         (mod2pi (second (pushtype-stack float)))
                                         (mod2pi (first (pushtype-stack float)))))))))
        (setf (pushtype-stack type)
              (cons (unitary-from-gate-forms pgm)
                    (pushtype-stack type))))
      (setf (pushtype-stack int) (rest (pushtype-stack int)))
      (setf (pushtype-stack float) (nthcdr 4 (pushtype-stack float))))))

(deftemplate halt 
  (add-qprog (list 'halt)))


(deftemplate end 
  (add-qprog (list 'end)))

(deftemplate measure
  (let ((int (find-pushtype 'integer)))
    (unless (null (pushtype-stack int))
      (let ((measurement-qubit (first (pushtype-stack int))))
        ;; pop the arg
        (setf (pushtype-stack int) (rest (pushtype-stack int)))
        ;; output measurement
        (add-qprog (list 'measure (legitimize-single-qubit measurement-qubit)))
        ))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; hack to ensure oracle call in every initial individual


(defun init-population ()
  "Initializes several globals including the pushgp population."
  (setq *push-names* nil)	;** push generated variables
  (random::seed-state *random-seed* *random-seed*)
  (pushgp-output "~%Initializing population, size=~A..." *population-size*)
  (setq *population* (make-array *population-size*))
  (dotimes (i *population-size*)
    (setf (aref *population* i)
          (random-individual)))
  ;;
  (dotimes (i *population-size*)
    (setf (individual-program (aref *population* i))
          (insert-code-at-point (individual-program (aref *population* i))
                                (randint (count-points (individual-program (aref *population* i))))
                                'QGATE.LIMITED-ORACLE)))
  )


;;; HACKAGE

#|
;; hacked to return a 6th value, avg-above-threshold-error ;***
(defun test-quantum-program (pgm &key num-qubits cases final-measurement-qubits
                                 threshold (inspect nil) (debug 0))
  "The top-level function to evaluate a quantum program relative to a list of                                                       
a list of (oracle value) cases. Returns a list of:                                                                                  
misses max-error average-error max-expected-oracles average-expected-oracles                                                        
See documentation for a more complete explanation of the arguments and                                                              
return values."
  (let ((misses 0)
        (max-error 0)
        (total-error 0)
        (total-above-threshold-error 0) ;***
        (average-error 0)
        (average-above-threshold-error 0) ;***
        (max-expected-oracles 0)
        (total-expected-oracles 0)
        (average-expected-oracles 0)
        (num-cases (length cases)))
    (dolist (case cases)
      (let* ((resulting-systems (execute-quantum-program
                                 pgm num-qubits (first case)))
             (raw-error (- 1.0 (nth (second case)
                                    (multi-qsys-output-probabilities
                                     resulting-systems final-measurement-qubits))))
             (expected-oracles (expected-oracles resulting-systems)))
        (when (> raw-error threshold) ;***
          (incf misses) 
          (incf total-above-threshold-error raw-error)) ;***
        (incf total-error raw-error)
        (when (> raw-error max-error)
          (setq max-error raw-error))
        (incf total-expected-oracles expected-oracles)
        (when (> expected-oracles max-expected-oracles)
          (setq max-expected-oracles expected-oracles))
        (when (>= debug 2)
          (format t "~%---~%Case:~A, Error:~,5F" case raw-error))
        (when inspect (inspect resulting-systems))))
    (setq average-error (/ total-error num-cases))
    (setq average-above-threshold-error (/ total-above-threshold-error num-cases)) ;***
    (setq average-expected-oracles (/ total-expected-oracles num-cases))
    (when (>= debug 1)
      (format t "~%~%Misses:~A" misses)
      (format t "~%Max error:~A" max-error)
      (format t "~%Average error:~A" (float average-error))
      (format t "~%Max expected oracles:~A" max-expected-oracles)
      (format t "~%Average expected oracles:~A" (float average-expected-oracles))
      (format t "~%Average above-threshold error:~A" (float average-above-threshold-error))) ;***
    (list misses max-error average-error max-expected-oracles average-expected-oracles average-above-threshold-error 0))) ;***
|#


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sigmoid-error.lisp
;; converts [0-1] error to [0-1] sigmoid around a provided threshold,
;; exponent (steepness), and compression
#|
(defparameter *sigmoid-exponent* (exp 1))
(defparameter *sigmoid-compression* (exp (exp 1))) ;(* (exp 1) (exp 1)))

(defun sig (error threshold)
  (/ 1 (+ 1 (exp (* (- *sigmoid-exponent*) 
                    (* *sigmoid-compression* (- error threshold)))))))
  



;; hacked to return a 6th value, avgerage-sigmoidal-error ;***
(defun test-quantum-program (pgm &key num-qubits cases final-measurement-qubits
                                 threshold (inspect nil) (debug 0))
  "The top-level function to evaluate a quantum program relative to a list of 
a list of (oracle value) cases. Returns a list of: 
misses max-error average-error max-expected-oracles average-expected-oracles
See documentation for a more complete explanation of the arguments and return values."
  (let ((misses 0)
        (max-error 0)
        (total-error 0)
        (total-sigmoidal-error 0) ;***
        (average-error 0)
        (average-sigmoidal-error 0) ;***
        (max-expected-oracles 0)
        (total-expected-oracles 0)
        (average-expected-oracles 0)
        (num-cases (length cases)))
    (dolist (case cases)
      (let* ((resulting-systems (execute-quantum-program
                                 pgm num-qubits (first case)))
             (raw-error (- 1.0 (nth (second case)
                                    (multi-qsys-output-probabilities
                                     resulting-systems final-measurement-qubits))))
             (expected-oracles (expected-oracles resulting-systems)))
        (if (> raw-error threshold) (incf misses))
        (incf total-sigmoidal-error (sig raw-error threshold)) ;***
        (incf total-error raw-error)
        (when (> raw-error max-error)
          (setq max-error raw-error))
        (incf total-expected-oracles expected-oracles)
        (when (> expected-oracles max-expected-oracles)
          (setq max-expected-oracles expected-oracles))
        (when (>= debug 2)
          (format t "~%---~%Case:~A, Error:~,5F" case raw-error))
        (when inspect (inspect resulting-systems))))
    (setq average-error (/ total-error num-cases))
    (setq average-sigmoidal-error (/ total-sigmoidal-error num-cases)) ;***
    (setq average-expected-oracles (/ total-expected-oracles num-cases))
    (when (>= debug 1)
      (format t "~%~%Misses:~A" misses)
      (format t "~%Max error:~A" max-error)
      (format t "~%Average error:~A" (float average-error))
      (format t "~%Max expected oracles:~A" max-expected-oracles)
      (format t "~%Average expected oracles:~A" (float average-expected-oracles))
      (format t "~%Average sigmoidal error:~A" (float average-sigmoidal-error))) ;***
    (list misses max-error average-error max-expected-oracles average-expected-oracles average-sigmoidal-error))) ;***
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; hacked to do matrix literalization

#|(defun problem-specific-report ()
  (let* ((sorted (sort *population* #'< :key #'individual-total-error))
         (best-pgm (individual-program (aref sorted 0))))
    ;; run the best program and get the qgame program
    (init-qprog)
    (runpush best-pgm)
    (let ((qgame-program (qprog)))
      (setq *unitary-literals*
            (mapcar #'second
                    (remove-if-not #'(lambda (gate-form) 
                                       (eq (first gate-form) 'matrix-gate))
                                   qgame-program))))
    (when *unitary-literals* (break "GOT ONE"))
    ))|#
#|
(defparameter *number-of-unitary-literals* 10)

(defun problem-specific-report ()
  (let* ((sorted (sort *population* #'< :key #'individual-total-error)))
    (setq *unitary-literals* nil)
    (do ((index 0 (1+ index)))
        ((or (>= index *population-size*)
             (>= (length *unitary-literals*) *number-of-unitary-literals*)))
      (let ((pgm (individual-program (aref sorted index))))
        ;; run the program and get the qgame program
        (init-qprog)
        (runpush pgm)
        (let ((qgame-program (thoroughly-compress-gates (qprog))))
          (setq *unitary-literals*
                (append *unitary-literals*
                        (mapcar #'(lambda (form)
                                    (make-unitary :matrix (second form)
                                                  :history (third form)))
                                (remove-if-not #'(lambda (gate-form) 
                                                   (eq (first gate-form) 'matrix-gate))
                                               qgame-program)))))))
    ;(when *unitary-literals* (break "GOT ONE"))
    ))
                                   
|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fitness

(defun upto (n)
  (if (zerop n)
    (list 0)
    (append (upto (- n 1)) (list n))))

(defun fitness (program)
  (let* ((huge-num 1E7)
         (errors (make-array *number-of-fitness-cases* 
                             :initial-element huge-num)))
    ;; we run the Push program just once FOR EACH ORACLE SIZE, with no input, to produce
    ;; the qgame program
    (dotimes (i *number-of-fitness-cases*)
      (let ((oracle-size (first (nth i *fitness-cases*)))
            (cases (second (nth i *fitness-cases*))))
        (setconstant 'numqubits oracle-size)
        (setq *number-of-qubits* oracle-size)
        (setq *all-qubits* (upto (- oracle-size 1)))
        (setq *measurement-qubits* (list (- oracle-size 1)))
        (setq *oracle-size* oracle-size)
        (setq *max-oracle-calls* 1) ;(floor (sqrt oracle-size)))
        
        (init-qprog)
        (runpush program)
        (let ((qgame-program (qprog)))
          ;; only bother to run if contains an oracle call
          (when (member 'LIMITED-ORACLE qgame-program :key #'car)
            (let ((test-results
                   (test-quantum-program qgame-program
                                         :num-qubits *number-of-qubits*
                                         :cases cases
                                         :final-measurement-qubits *measurement-qubits*
                                         :threshold 0.48
                                         :inspect nil
                                         :debug 0)))
              ;; results are: misses max-error average-error 
              ;;                     max-expected-oracles average-expected-oracles
              ;; qgame does not have lexicographic fitness
              (setf (aref errors i)
                    (+  
                     (nth 0 test-results)                     ;; misses
                     (nth 1 test-results)                     ;; max-error
                     
                     )))))))
    errors))


;; configure and run pushgp
;(configure-push-from-file (choose-file-dialog))
;(pushgp)