student.lsp

基因演算法source code範例vc

;exp's form = (op lhs rhs)
(defun exp-lhs (e) (second e))
(defun exp-rhs (e) (third e))
(defun exp-op  (e) (first e))
(defun swap-exp(e)
       `(,(exp-op e) ,(exp-rhs e) ,(exp-lhs e))	)
(defun in-exp  (x e)
       (or (eq x e)
	   (and	(listp e)
		(or (in-exp x (exp-lhs e))(in-exp x (exp-rhs e)))
)      )   )
(defun inverse-op (op)
   (cond ((eq op '+) '-)
	 ((eq op '-) '+)
	 ((eq op '*) '/)
	 ((eq op '/) '*)
	 ((eq op '=) '=)
)  )
(defun commutative-op (op)
       (member op '(+ *	=))
)
(defun isolate (e x)
  (format t "~&--> ~A" (pre-2-in e))
  (cond	((eq (exp-lhs e) x)	  ;Case	I X=A -> X = n
	 (let ((ans (eval (exp-rhs e))))
	  (format t "~&Ans ~A =	~A" x ans)
	  ans
	))
	;Case II A=F(x)	-> F(x)= A
	((and (in-exp x	(exp-rhs e))(not (in-exp x (exp-lhs e))))
	 (format t "~&Use ~A"  "A=F(x) -> F(x)=A")
	 (isolate  (swap-exp e)	x)
	)
	;Case II-1 F(x)=G(x) ->	F(x)-G(x)= 0
	((and (in-exp x	(exp-rhs e))(in-exp x (exp-lhs e)) )
	  (format t "~&Use ~A"	"F(x)=G(x) -> F(x)-G(x)= 0")
	  (isolate  (simp-equation e x)	x)
	)
	((in-exp x (exp-lhs (exp-lhs e))) ;Case	III f(x)*A=B ->	f(x)=B/A
	 (format t "~&Use ~A"  "f(x)*A=B -> f(x)=B/A")
	 (isolate `(,(exp-op e)	,(exp-lhs (exp-lhs e))
		    (,(inverse-op (exp-op (exp-lhs e)))	,(exp-rhs e)
		      ,(exp-rhs	(exp-lhs e))
		   )) x	)
	)
	((commutative-op (exp-op (exp-lhs e))) ;Case IV	A*f(x)=B -> f(x)= B/A
	 (format t "~&Use ~A"  "A*f(x)=B -> f(x)= B/A")
	 (isolate `(,(exp-op e)	,(exp-rhs (exp-lhs e))
		    (,(inverse-op (exp-op (exp-lhs e)))	,(exp-rhs e)
		     ,(exp-lhs (exp-lhs	e))
		   )) x	)
	)
	(t			;Case V	A/f(x)=B -> f(x)= A/B
	 (format t "~&Use ~A"  "A/f(x)=B -> f(x)= A/B")
	 (isolate `(,(exp-op e)	,(exp-rhs (exp-lhs e))
		    (,(exp-op (exp-lhs e)) ,(exp-lhs (exp-lhs e))
		      ,(exp-rhs	e)
		   )) x	)
	)
) )

(defun solve (exps ans)
  (or (some #'(lambda (exp)
	    (let ((x (one-unknown exp)))
		 (when x
		     (let ((y (isolate exp x)))
		       (solve (subst  y	x (remove exp exps))
			      (cons `(,x = ,y) ans)
	  ) )	 )   ) )
	  exps
      )
      ans
) )


(defun solve1 (exps ans)
  (dolist (exp exps 'done!)
     (let ((x (one-unknown exp)))
	  (if (null x)
	      nil
	      (let ((y (isolate	exp x)))
		 (solve1 (subst	y x (remove exp	exps))
			 (cons `(,x = ,y) ans)
) )  )	  )   )	 )







(defun one-unknown (exp)
	(if (= 1 (unknowns-num exp))
	    (car (unknowns exp))
	    nil
)	)
(defun unknowns	(exp)
  (let ((xs nil))
    (labels ((unk1 (e)
	      (cond  ((symbolp e) (setf	xs (adjoin e xs)))
		     ((atom e) t)
		     (t
		      (unk1 (exp-lhs e))
		      (unk1 (exp-rhs e))
	    )))	     )
       (unk1 exp)
    )
  xs
) )

(defun unknowns-num (exp)
       (length (unknowns exp))
)










(defun pre-2-in	(L)
   (cond ((atom	L) L)
	 ((= 2 (length L))
	  (list	(first L) (pre-2-in (second L))))
	 (t
	  (list	(pre-2-in (second L))
		 (first	L)
		 (pre-2-in (third L)))
)  )	 )