gen.lsp

基因演算法source code範例vc

(defparameter Population_size 6)
(defparameter Gen_len	      5)
(defparameter Gens	      nil)
(defparameter Gens_score      nil)
(defparameter index	      '(16 8 4 2 1))
(defparameter Selcet	      nil)

(defun Target (x)
  (let ((ans 0))
       (dotimes	(i Gen_len 'doneEval)
	   (setf ans (+	ans (* (nth i index)(nth i x))))
       )
       (setf ans (- 1 (* ans ans)))
       ans
) )

(defun SelectR ()
  (setf	Select nil)
  (let ((ans Gens_score)(y 0))
       (setf ans (qsort	ans))
       (dolist (x ans 'donex)
	   (setf y -1)
	   (loop (setf y (1+ y))
	      (cond
		  ((= x	(nth y Gens_score))
		   (setf Select	`(,@Select ,y))
		   (return 'find)
		  )
		  (t nil)
  )    )   )  )
  (setf	Select (reverse	Select))
)

(defun GP ()
   (InitPopulation)
   (loop
    (FitEval)
    (SelectR)
    (format t "~&Gens=~A~&Score=~A" Gens Gens_Score)
    (let* ((r1 (nth (nth 0 Select) Gens))
	   (c1 (random 5))
	   (c2 (random 5))
	   (c3 (random 5))
	   (c4 (random 5))
	   (r23	(CrossOp (nth (nth c1 Select) Gens)
			 (nth (nth c2 Select) Gens)))
	   (r45	(CrossOp (nth (nth c3 Select) Gens)
			 (nth (nth c4 Select) Gens)))
	   (r6	(MutOp (nth (nth 1 Select) Gens)))
	   (y nil)
	  )
	  (setf	Gens `(,r1 ,@r23 ,@r45 ,r6) )
	  (setf	y (read))
	  (when	(= 1 y)	(return	'Done))
)  ))

(defun MutOp (x)
   (let* ((cpt (random Gen_len))
	  (ans nil)
	  (value (nth cpt x))
	 )
	 (cond ((= 0 value)
		(setf (nth cpt x) 1)
		(setf ans x)
	       )
	       ((= 1 value)
		(setf (nth cpt x) 0)
		(setf ans x)
	 )     )
	 ans
)  )

(defun InitPopulation ()
  (setf	Gens nil)
  (dotimes (x Population_size 'doneInit)
       (setf Gens `(,@Gens ,(CreateGen)))
) )

(defun CreateGen ()
  (let ((ans nil))
       (dotimes	(x Gen_len 'doneCreate)
	   (setf ans `(,@ans ,(random 2)))
       )
       ans
) )

(defun FitEval ()
   (setf Gens_score nil)
   (dotimes (x Population_size 'doneFit)
       (setf Gens_score	`(,@Gens_score ,(Target	(nth x Gens))))
)  )
(defun qsort (L)
  (let ((head (first L))
	(SmallL	())
	(BigerL	())
       )
       (cond ((null L) ())
	     ((= 1 (length L)) L)
	     (t
	      (dolist (x (cdr L) 'done)
		  (if (< x head)
		      (setf SmallL (append (list x) SmallL))
		      (setf BigerL (append (list x) BigerL))
		 ))
      (setf SmallL (append SmallL (list	head)))
     (append (qsort SmallL) (qsort BigerL))
     ))
    ))

(setf Info nil)

(defun CrossOp (x y)
   "Given two lists, then produce two new lists"
   (let*  ((pt1	 (ChosePt))
	   (tmpx (SplitList x pt1))
	   (tmpy (SplitList y pt1))
	   (newx (append (car tmpx)(cadr tmpy))	)
	   (newy (append (car tmpy)(cadr tmpx))	)
	  )
	  (list	newx newy)
)  )
(defun cross1 (x y)
   "Given two lists, then produce two new lists"
   (let*  ((pt1	 (ChoosePt x))
	   (pt2	 (ChoosePt y) )
	   (tmpx (SplitTree x pt1))
	   (tmpy (SplitTree y pt2))
	   (newx (subst	(second	tmpy) '@ (car tmpx) :test #'equal))
	   (newy (subst	(second	tmpx) '@ (car tmpy) :test #'equal))
	  )
	  (when	Info (progn
		      (format t	"~& X split at ~d , Y split at ~d" pt1 pt2)
		      (format t	"~& X befor ~A"	x)
		      (format t	"~&   after ~A"	newx)
		      (format t	"~& Y befor ~A"	y)
		      (format t	"~&   after ~A"	newy)
	  )	     )
	  (list	newx newy)
)  )

(setf tree1 '(+	(* 3 5)(* (+ 2 (/ 5 3))	1)))
(setf tree2 '(*	4 (+ (*	2 2) (/	5 3))) )

(defun SplitTree (x cpt)
   "Split x tree at internal point cpt into (part1 part2)"
   (let* ((subt1 (catch	'subt (subtree x cpt 0)))
	  (rest1 (subst	'@ subt1 x :test #'equal))
	 )
	 (when Info (format t "~& rest is ~a~& subtree is ~a" rest1 subt1))
	 (list rest1 subt1)
)  )

(defun SplitList (x cpt)
   "Split x list at internal point cpt into (part1 part2)"
   (let	((r1 nil)(r2 nil)(count	0))
	(dolist	(y x 'done)
	   (if (< count	cpt)
	       (setf r1	`(,@r1 ,y))
	       (setf r2	`(,@r2 ,y)) )
	   (setf count (1+ count))  )
	(list r1 r2)
)  )

(defun subtree (x cpt count)
   "Return the subtree of x at point cpt"
   (cond
	((listp	x)
	  (incf	count)
	  (if (= cpt count)
	      (throw 'subt x)
	      (let* ((x1 (subtree (second x) cpt count))
		     (x2 (subtree (third  x) cpt x1   ))
		    )
		    x2
	) )   )
	(t count)
)  )


(defun ChosePt ()
   "Choose a cross point."
   (1+ (Random Gen_len))
)
(defun ChoosePt	(x)
   "Choose a cross point."
   (1+ (Random (CountInterNode x)))
)

(defun CountInterNode (x)
   "Return the number of internal nodes# of x"
   (cond
    ((atom x) 0)
    (t (let ( (count (+	1 (CountInterNode (second x))
			  (CountInterNode (third x) )
	    ) )	     )
	    count
)  ))  )