; lisp2prolog 0.0.1                                              12. 1. 2004
;
; Author: Jiri Verunek  http://jiri.verunek.net/
;
; This program is distributed under the GNU General Public Licence, version 2.
; See http://www.gnu.org for more details.
;
; The program can process arithmetical expressions with variables and numbers
; as operands and operations +, -, *, /.
; Cons cell manipulating functions `car', `cdr' and `cons' are supported.
; `Nil' represents an empty list.
; Inequality can be tested by operators >, <, >=, <=,
; equality by  `=' and `eq'.
; The most important part of the translator is the code forking with the
; `cond' function which can be even located in the place where the arithmetical
; expression operand is expected.


; --- AUXILIARY MACROS ---
; return value
(defmacro st_retval (STATE)
  `(car ,STATE))

; simple assignment
; This flag set to T indicates that the current clause can return
;   number, variable or arithmetical expression.
; If it is set to nil, only a number or variable can be returned.
(defmacro st_sass (STATE)
  `(cadr ,STATE))

; variables with values
(defmacro st_varval (STATE)
  `(caddr ,STATE))

; prolog output
(defmacro st_prolog (STATE)
  `(cadddr ,STATE))

; rule parameters
(defmacro st_rulepar (STATE)
  `(car (cddddr ,STATE)))


; --- TEMPORARY VARIABLES FUNCTIONS ---
; Prolog does not allow to handle arithmetical expressions in the predicate
; parameters so we have to bound this expression to some temporary variable
; first and then call the predicate with this variable as the parameter.

; Temporary variables are also used for cons cells.

; Initialise the temporary variable counter.
; The counter is global for all clauses of the predicate.
; This function is called from the _defun function.
(defun init_tmpvarcnt ()
  (setf TMP_VAR_CNT 1))

(defun inc_tmpvarcnt ()
  (setf TMP_VAR_CNT (1+ TMP_VAR_CNT)))

(defun get_tmpvarcnt ()
  TMP_VAR_CNT)


; It creates the temporary variable which name is not conflicting
; with other variable names.
; DO NOT FORGET to call init_tmpvarcnt before the first call of this function.
(defun create_tmpvar (STATE)
  (let ((TMPVAR (intern (concatenate 'string
				     "T"
				     (princ-to-string (get_tmpvarcnt))))))
    (inc_tmpvarcnt)
    (cond ((not (variablep STATE TMPVAR))
	   (add_variable STATE TMPVAR)
	   (variable_eval_mark TMPVAR))
	  ((create_tmpvar STATE)))))

; Add the variable to the list with variables and their values.
(defun add_variable (STATE SYMBOL &optional (VALUE SYMBOL))
  (setf (st_varval STATE) (append (st_varval STATE) (list SYMBOL VALUE)))
  SYMBOL)

(defun set_variable (STATE VARIABLE VALUE)
  (let ((VAR VARIABLE) (VAL VALUE) (OLD_VAL))
    ; If the VARIABLE is ('PRINT-VALUE . A) set VAR to A
    (cond ((and (consp VARIABLE) (eq (car VARIABLE) 'PRINT-VALUE))
	   (setf VAR (cdr VARIABLE))))
    ; If the VALUE is ('PRINT-VALUE . B) set VAL to B
    (cond ((and (consp VALUE) (eq (car VALUE) 'PRINT-VALUE))
	   (setf VAL (cdr VALUE))))

    (setf OLD_VAL (evaluate STATE VAR))
    (cond
     ; There is still no variable with the name VAR,
     ; so add the new variable VAR with value VAL to this STATE.
     ((equal OLD_VAL "NIL")
      (add_variable STATE VAR VAL))
     ; There is already the variable VAR but have no assigned value,
     ; so assign the value VAL to this variable.
     ((eq OLD_VAL VAR)
      (setf (getf (st_varval STATE) VAR "NIL") VAL))
     ; There is already the variable VAR and also has an assigned value,
     ; so create a prolog row with the binding.
     ((append_code STATE (list (variable_eval_mark VAR) " = " VAL)))))
  STATE)

; the caller expects this function returns the VALUE
(defun set_retval (STATE VALUE)
  (setf (st_retval STATE) VALUE))


; Look at the auxiliary macros definition
; to know the structure of the state list.
(defun initial_state_list () '((()()()()())))

;------------


(defun call_function_by_symbol (STATE_LIST FUNCTION_NAME PARAMS)
  (cond
   ((or (eq FUNCTION_NAME '=)
	(eq FUNCTION_NAME 'eq))
    (combine_call_with_parsed_parameters STATE_LIST
					 '_=
					 nil ; SIMPLE_PARAMETERS
					 T ; simple assignment
					 PARAMS))
   ((eq FUNCTION_NAME '+) (combine_call_with_parsed_parameters
			   STATE_LIST
			   'bin_arithm_op
			   (list " + " 500)
			   T ; simple assignment
			   PARAMS))
   ((eq FUNCTION_NAME '-) (combine_call_with_parsed_parameters
			   STATE_LIST
			   'bin_arithm_op
			   (list " - " 499)
			   T ; simple assignment
			   PARAMS))
   ((eq FUNCTION_NAME '*) (combine_call_with_parsed_parameters
			   STATE_LIST
			   'bin_arithm_op
			   (list " * " 400)
			   T ; simple assignment
			   PARAMS))
   ((eq FUNCTION_NAME '/) (combine_call_with_parsed_parameters
			   STATE_LIST
			   'bin_arithm_op
			   (list " / " 400)
			   T ; simple assignment
			   PARAMS))
   ((eq FUNCTION_NAME '>) (combine_call_with_parsed_parameters
			   STATE_LIST
			   'relation_op
			   (list " > ") ; SIMPLE_PARAMETERS
			   nil ; simple assignment
			   PARAMS))
   ((eq FUNCTION_NAME '>=) (combine_call_with_parsed_parameters
			    STATE_LIST
			    'relation_op
			    (list " >= ") ; SIMPLE_PARAMETERS
			    nil ; simple assignment
			    PARAMS))
   ((eq FUNCTION_NAME '<) (combine_call_with_parsed_parameters
			   STATE_LIST
			   'relation_op
			   (list " < ") ; SIMPLE_PARAMETERS
			   nil ; simple assignment
			   PARAMS))
   ((eq FUNCTION_NAME '<=) (combine_call_with_parsed_parameters
			    STATE_LIST
			    'relation_op
			    (list " =< ") ; SIMPLE_PARAMETERS
			    nil ; simple assignment
			    PARAMS))
   ((eq FUNCTION_NAME 'null)
    (call_function_by_symbol STATE_LIST 'eq (cons nil PARAMS)))
   ((eq FUNCTION_NAME 'cond) (_cond STATE_LIST
				    PARAMS))
   ((eq FUNCTION_NAME 'cons) (combine_call_with_parsed_parameters
			      STATE_LIST
			      '_cons
			      nil ; SIMPLE_PARAMETERS
			      nil ; simple assignment
			      PARAMS))
   ((eq FUNCTION_NAME 'car) (combine_call_with_parsed_parameters
			     STATE_LIST
			     '_car_cdr
			     (list 'cadr) ; SIMPLE_PARAMETERS  ("C" CAR CDR)
			     nil ; simple assignment
			     PARAMS))
   ((eq FUNCTION_NAME 'cdr) (combine_call_with_parsed_parameters
			     STATE_LIST
			     '_car_cdr
			     (list 'caddr) ; SIMPLE_PARAMETERS  ("C" CAR CDR)
			     nil ; simple assignment
			     PARAMS))
   ((symbolp FUNCTION_NAME) (combine_call_with_parsed_parameters
			     STATE_LIST
			     'other_function
			     (list FUNCTION_NAME)
			     nil ; simple assignment
			     PARAMS))
   (t 'UNIMPLEMENTED_FUNCTION)))

; Each variable in the prolog code is represented by this cons cell.
; When printing prolog function reaches a cell it calls the function,
; which symbol is stored in the car, with cdr as parameter.
(defun variable_eval_mark (VARIABLE)
  (cons 'print-value VARIABLE))

(defun get_symbol (VARIABLE)
  (cond ((and (consp VARIABLE) (eq (car VARIABLE) 'PRINT-VALUE))
	 (cdr VARIABLE))
	(t VARIABLE)))

(defun get_number_or_eval_mark (X)
  (cond ((numberp X) X)
	((and (consp X)
	      (eq (car X)
		  'PRINT-VALUE))
	 X)
	((variable_eval_mark (X)))))


; Returns if the SYMBOL is a member of the varval property of the STATE.
(defun variablep (STATE SYMBOL)
  (cond ((symbolp SYMBOL)
	 (not (equal "NIL" (getf (st_varval STATE) SYMBOL "NIL"))))
	((and (consp SYMBOL) (equal (car SYMBOL) 'PRINT-VALUE))
	 (not (equal "NIL" (getf (st_varval STATE) (cdr SYMBOL) "NIL"))))
	(t NIL)))

; Returns if the VARIABLE is the clause argument.
; This is used to make the prolog code more beautiful --- to preserve
; LISP variable names.
(defun argumentp (STATE VARIABLE)
  (cond ((symbolp VARIABLE)
	 (eq (find VARIABLE (st_rulepar STATE)) VARIABLE ))
	((and (consp VARIABLE) (equal (car VARIABLE) 'PRINT-VALUE))
	 (eq (find (cdr VARIABLE) (st_rulepar STATE)) (cdr VARIABLE)))
	(t NIL)))

; Returns if a value has NOT been assigned to the VARIABLE.
(defun not_initialised_variable (STATE VARIABLE)
  (eq (get_symbol VARIABLE)
      (get_symbol (evaluate STATE VARIABLE))))

; Returns if a value has been assigned to the VARIABLE.
(defun initialised_variable (STATE VARIABLE)
  (not (not_initialised_variable STATE VARIABLE)))

; Returns if the VALUE is a cons cell - (list "C" CAR CDR).
(defun myconsp (VALUE)
  (and (consp VALUE) (equal "C" (car VALUE))))

; Returns if the VALUE is a nil - (list "NIL").
(defun mynull (VALUE)
  (and (consp VALUE) (equal "[]" (car VALUE))))


(defun _defun (NAME PARAMS &rest BODY)
  (init_tmpvarcnt)
  (let ((STATE_LIST (initial_state_list)))
    (cond
     (t (setf (st_varval (car STATE_LIST)) (init_varval PARAMS))
	(setf (st_prolog (car STATE_LIST))
	      (list (cons NAME (put-params (car STATE_LIST) PARAMS))))
	(setf STATE_LIST (parse_exp_list STATE_LIST BODY))
	(print_prolog STATE_LIST)))
    STATE_LIST))

; Initialize list containing variables and their values.
; (X Y Z) -> (X X Y Y Z Z)
(defun init_varval (L)
  (cond ((null L) nil)
	((union (list (car L) (car L)) (init_varval (cdr L))))))

; Set the parameters of the current state to PARAMS
; and return list with the print-params function which will be called
; by print-prolog function.
(defun put-params (STATE PARAMS)
  (setf (st_rulepar STATE) PARAMS)
  (list (cons 'print-params nil)))

; (X Y Z) -> ((print-value . X) "," (print-value . Y) "," (print-value . Z))
(defun commas-param-list (PL)
  (cond ((null (cdr PL)) (list (cons 'print-value (car PL))))
	((cons
	  (cons 'print-value (car PL))
	  (cons "," (commas-param-list (cdr PL)))))))


(defun deep-copy (L)
  (cond ((atom L) L)
	((cons (deep-copy (car L)) (deep-copy (cdr L))))))

; (clone-states 3 '(A B) nil)  ->  ((A B) (A B) (A B))
(defun clone-states (PARTS_COUNT STATE_LIST STATE_LIST_TEMP)
  (cond ((= 1 PARTS_COUNT) (cons (deep-copy STATE_LIST) STATE_LIST_TEMP))
	((clone-states (1- PARTS_COUNT)
		       STATE_LIST
		       (cons (deep-copy STATE_LIST) STATE_LIST_TEMP)))))

;;(defun clone-states (PARTS_COUNT STATE_LIST)
;;  (make-list PARTS_COUNT :initial-element STATE_LIST))


; Append the part of the prolog code specified by the NC parameter to the
; prolog code of the current STATE.
(defun append_code (STATE NC)
  (setf (st_prolog STATE) (append (st_prolog STATE) (list NC))))


; Get the value of the symbol VARIABLE
; or the symbol X in the cons cell ('PRINT-VALUE . X).
(defun evaluate (STATE VARIABLE)
  (getf (st_varval STATE)
	(cond ((and (consp VARIABLE) (eq 'PRINT-VALUE (car VARIABLE)))
	       (cdr VARIABLE))
	      (t VARIABLE))
	"NIL"))

; This function prints comma separated clause arguments and return value.
(defun print-params (STATE IGNORE_PARAMETER_IN_CDR)
  ; Create the list with argument values and
  ; append the return value to this list.
  (let ((params
	 (append
	  ; Create a list with evaluated rule parameters.
	  (mapcar #'(lambda (PAR) (evaluate STATE PAR))
		  (st_rulepar STATE))
	  ; return value
	  (cond ((null (st_retval STATE)) nil) ; no output value
;;		((and (consp (st_retval STATE))
;;		      (eq 'PRINT-VALUE (car (st_retval STATE))))
;;		 (list (cdr (st_retval STATE))))
		((list (st_retval STATE)))))))
    ; If the list with rule parameters is not empty, print this parameters
    ; comma separated and outbounding parentheses.
    (cond ((not (null params))
	   (myformat "(")
	   (print-param-comma STATE params)))))

; Print the comma separated params.
; This function is called from the print-params function.
(defun print-param-comma (STATE PARAMS)
  (cond ((null PARAMS) (myformat ")"))
	(t (cond ((myconsp (car PARAMS)) (print-cons STATE (car PARAMS)))
		 ((mynull (car PARAMS)) (print-nil))
		 ((consp (car PARAMS)) ; value is another variable
		  (funcall (caar PARAMS) STATE (cdar PARAMS)))
		 ((myformat (car PARAMS))))
	   ; If there is another parameter, write comma character `,'.
	   (cond ((not (null (cdr PARAMS))) (myformat ",")))
	   (print-param-comma STATE (cdr PARAMS)))))


; (clone-params '( (A1 A2) (B1 B2 B3) (C) )  nil)  ->
;   ->  ((A1 B1 C) (A2 B1 C) (A1 B2 C) (A2 B2 C) (A1 B3 C) (A2 B3 C))
(defun clone-params (L L_TMP)
  (cond ((null L) L_TMP)
	((clone-params
	  (cdr L)
	  (cond ((null (car L)) L_TMP)
		((mapcar #'(lambda (A B)
			     (cond ((null A) (list B))
				   ((append A (list B)))))
			 
			 (cond ((null L_TMP) 
				(clone-states (max 1 (length (car L)))
					      L_TMP
					      nil))
			       ((apply #'append
				       (clone-states (max 1 (length (car L)))
						     L_TMP
						     nil))))

			 (cond ((null L_TMP) (car L))
			       ((apply
				 #'append
				 (mapcar #'(lambda (X)
					     (clone-states
					      (max 1 (length L_TMP))
					      X
					      nil))
					 (car L))))))))))))

; It calls the FUNC with the all combinations of parameters in the PARAMS list.
; FUNC function does not need to care of mapcar.
(defun combine (STATE_LIST FUNC SIMPLE_PARAMS_LIST &rest PARAMS)
  (mapcan #'(lambda (PARAMS_LIST)
	      (apply FUNC
		     ; put back the top level parenthesis
		     ; of the STATE_LIST stolen by the `apply' function.
		     ; STATE_LIST is the 1st member of the list.
		     (cons (list (car PARAMS_LIST))
			   (append SIMPLE_PARAMS_LIST
				   (cdr PARAMS_LIST)))))
	  (clone-params (cons STATE_LIST PARAMS) nil)))

; main function
; Open the input stream with LISP code.
(defun lisp2prolog (FILE)
  (read_lisp (open FILE :direction :input)))

; Create a list with prolog functions and call the function parse_lisp_program
; for executing the translation.
(defun read_lisp (STREAM &optional (CODE nil))
  (let ((ELEMENT (read STREAM nil nil)))
    (cond ((null ELEMENT)
	   (close STREAM)
	   (parse_lisp_program CODE))
	  ((read_lisp STREAM (append CODE (list ELEMENT)))))))

(defun parse_lisp_program (A)
  (cond ((null A) A)
	((and (consp (car A)) (eq 'defun (caar A)))
	 (apply #'_defun (cdar A))
	 (parse_lisp_program (cdr A)))
	(t 'FORBIDDEN_TOP_LEVEL_EXPRESSION)))


(defun parse_exp (STATE_LIST &rest EXPS)
  (parse_exp_list STATE_LIST EXPS))

(defun parse_exp_list (STATE_LIST EXPS)
  (cond ((null EXPS) STATE_LIST)
	((parse_exp_list (parse_one_exp STATE_LIST (car EXPS)) (cdr EXPS)))))

(defun parse_one_exp (STATE_LIST EXP)
  (cond ((consp EXP) (parse_func STATE_LIST EXP))
	((numberp EXP) (parse_number STATE_LIST EXP))
;	((stringp EXP) (parse_string STATE_LIST EXP))
	((parse_variable STATE_LIST EXP))))


; L is list with function name and parameters.
(defun parse_func (STATE_LIST L)
  (call_function_by_symbol STATE_LIST (car L) (cdr L)))


; The STATE_LIST in the lambda function has only one STATE!
; It is guaranteed by the combine function.
(defun parse_number (STATE_LIST NUMBER)
  (combine STATE_LIST
	   #'(lambda (STATE_LIST NUMBER)
	       (set_retval (car STATE_LIST) NUMBER)
	       STATE_LIST)
	   nil
	   (list NUMBER)))

(defun parse_variable (STATE_LIST VARIABLE)
  (combine STATE_LIST
	   #'(lambda (STATE_LIST VARIABLE)
	       (set_retval (car STATE_LIST)
			   (cond ((null VARIABLE) (list "[]"))
				 ((variable_eval_mark VARIABLE))))
	       STATE_LIST)
	   nil
	   (list VARIABLE)))


(defun set_sass (STATE &optional (VALUE T))
  (setf (st_sass STATE) VALUE)
  STATE)

(defun _cond (STATE_LIST VARIANTS)
  (mapcan #'(lambda (STATE)
	      (combine (list (deep-copy STATE)) ; je nutne deep-copy? *******
		       'process_cond_variant
		       nil
		       VARIANTS))
	      STATE_LIST)
)

(defun process_cond_variant (STATE_LIST VARIANT)
  (parse_exp_list (parse_one_exp STATE_LIST
				 (car VARIANT))
		  (cdr VARIANT))
)


(defun _cons (SL_OLD ST_CAR ST_CDR)
  (let ((ST (merge_all_states (car SL_OLD) ST_CAR ST_CDR))
	(TMP_VAR))
    (setf TMP_VAR (create_tmpvar ST))
    (set_variable ST TMP_VAR (list "C"
				   (st_retval ST_CAR)
				   (st_retval ST_CDR)))
    (set_retval ST TMP_VAR)
  (list ST)))

(defun _car_cdr (IGNORE_STATE_LIST FUNC ST)
  (let ((VALUE (evaluate ST (st_retval ST))))
    (cond
     ((and (variablep ST (st_retval ST))
	   (not_initialised_variable ST (st_retval ST)))
      (set_variable ST
		    (st_retval ST)
		    (setf VALUE
			  (list "C"
				(create_tmpvar ST)
				(create_tmpvar ST))))))
    (cond ((myconsp VALUE)
	   (set_retval ST
		       (get_number_or_eval_mark (funcall FUNC VALUE)))
	   (list ST))
	  (t 'CONS_ERROR))))


; Calls the FUNCTION with parameters.
; Each parameter of PARAMS list is parsed first with
; `single assignment' property of the state set to SASS.
; Returns a state list.
(defun combine_call_with_parsed_parameters
  (STATE_LIST FUNCTION SIMPLE_PARAMS SASS PARAMS)
  (mapcan #'(lambda (STATE)
	      (apply 'combine
		     (list STATE)
		     FUNCTION
		     SIMPLE_PARAMS
		     (parse_sassed_exps STATE PARAMS SASS)))
	  STATE_LIST))


; Returns a list of state lists of the parsed expressions.
(defun parse_sassed_exps (STATE EXPS SASS &optional (SASSED_EXPS nil))
  (cond ((null EXPS) SASSED_EXPS)
	  ((parse_sassed_exps
	    STATE
	    (cdr EXPS)
	    SASS
	    (append SASSED_EXPS
		    (list (parse_one_sassed_exp STATE
						(car EXPS)
						SASS)))))))
  
; Returns state list of the parsed expression.
(defun parse_one_sassed_exp (STATE ONE_PARAMETER SASS)
  (parse_one_exp
   (list (set_sass
	  (deep-copy STATE)
	  SASS))
   ONE_PARAMETER))


; State list is ignored because it was input state list
; of the function parametres which returned state lists are stored
; in PARAMS list.
(defun other_function (IGNORE_STATE_LIST FUNCTION_NAME &rest PARAMS)
  (let ((TMP_VAR))
    (append_code (car PARAMS) ; This will be the returned state list.
		 (cons FUNCTION_NAME
		       ; Create a list with parameters of the predicate.
		       (cons "("
			     (append
			      ; create a list with evaluated function
			      ; arguments separated by commas.
			      (mapcan #'(lambda (STATE)
					  (list (st_retval STATE) ","))
				      PARAMS)
			      ; Append the return value of this predicate
			      ; to the list.
			      (list (setf TMP_VAR
					  (create_tmpvar
					   (merge_all_states_in_list
					    (car PARAMS)
					    (cdr PARAMS))))
				    ")")
			      ))))
    (set_retval (car PARAMS) TMP_VAR))
  (list (car PARAMS))
  )


(defun relation_op (SL_OLD OP_STRING ST1 ST2)
  (let ((ST (merge_all_states (car SL_OLD) ST1 ST2)))
    (append_code ST (list (st_retval ST1) OP_STRING (st_retval ST2)))
    (setf (st_retval ST) nil)
    (list ST)))

(defun bin_arithm_op (SL_OLD OP_STRING PRECEDENCE ST1 ST2)
  (let ((ST (merge_all_states (car SL_OLD) ST1 ST2))
	(E1_PREC 0) (E1_LIST nil) (RV1 (st_retval ST1))
	(E2_PREC 0) (E2_LIST nil) (RV2 (st_retval ST2)))
    (cond ((and (consp RV1) (equal (car RV1) "E"))
	   (setf E1_PREC (cadr RV1))
	   (setf E1_LIST (cddr RV1)))
	  ((setf E1_LIST (list RV1))))
    (cond ((and (consp RV2) (equal (car RV2) "E"))
	   (setf E2_PREC (cadr RV2))
	   (setf E2_LIST (cddr RV2)))
	  ((setf E2_LIST (list RV2))))
    (cond ((> E1_PREC PRECEDENCE) (setf E1_LIST (append (cons "(" E1_LIST)
							(list ")")))))
    (cond ((> E2_PREC PRECEDENCE) (setf E2_LIST (append (cons "(" E2_LIST)
							(list ")")))))
    (cond ((st_sass ST)
	   (set_retval ST (append (list "E" PRECEDENCE)
				  E1_LIST
				  (cons OP_STRING E2_LIST))))
	  ((let ((TMPVAR (create_tmpvar ST)))
	     (append_code ST (append (list TMPVAR " is ")
				     E1_LIST
				     (list OP_STRING)
				     E2_LIST))
	     (set_retval ST TMPVAR))))
    (list ST)))


(defun _= (SL_OLD ST1 ST2)
  (let ((ST (merge_all_states (car SL_OLD) ST1 ST2))
	(E1_LIST nil) (RV1_IS_EXP nil) (RV1 (st_retval ST1))
	(E2_LIST nil) (RV2_IS_EXP nil) (RV2 (st_retval ST2))
	(RV nil) (TMP_VALUE nil))
    (cond ((and (consp RV1) (equal (car RV1) "E"))
	   (setf E1_LIST (cddr RV1))
	   (setf RV1_IS_EXP T))
	  ((setf E1_LIST (list RV1))))
    (cond ((and (consp RV2) (equal (car RV2) "E"))
	   (setf E2_LIST (cddr RV2))
	   (setf RV2_IS_EXP T))
	  ((setf E2_LIST (list RV2))))

    (cond (RV1_IS_EXP
	   (cond ((variablep ST RV2) ; 3 + 1 = X
		  (append_code ST (cons RV2 (cons " is " E1_LIST))))
		 (RV2_IS_EXP ; 3 + 1 = 2 + 2
		  (setf TMP_VALUE (create_tmpvar ST))
		  (append_code ST (cons TMP_VALUE (cons " is " E1_LIST)))
		  (append_code ST (cons TMP_VALUE (cons " is " E2_LIST))))
		 ((append_code ST (cons RV2 (cons " is " E1_LIST)))))); 3+1 =4
	  ((variablep ST RV1)
	   (cond (RV2_IS_EXP ; X = 3 + 1
		  (append_code ST (cons RV1 (cons " is " E2_LIST))))
		 ((variablep ST RV2)
		  (cond ((and (not_initialised_variable ST RV1)
			      (not_initialised_variable ST RV2))
			 (cond ((argumentp ST RV1)
				(set_variable ST RV2 RV1))
			       ((set_variable ST RV1 RV2))))
			((initialised_variable ST RV1)
			 (set_variable ST RV2 (evaluate ST RV1)))
			((set_variable ST RV1 (evaluate ST RV2)))))
		 ((set_variable ST RV1 RV2)))) ; X = 4
	  ((cond ((variablep ST RV2) ; 4 = X
		  (set_variable ST RV2 RV1))
		 (RV2_IS_EXP ; 4 = 3 + 1
		  (append_code ST (cons RV1 (cons " is " E2_LIST))))
		 ((append_code ST (cons RV1 (cons " = " E2_LIST))))))) ; 4 = 4

    (list ST)))
; What return value should be set?  (set_retval ST RV)



; ----- FUNCTIONS FOR MERGING STATES -----


; When all function parameters are evaluated - they have returned state lists,
; is it neccessary to merge these state lists.
(defun merge_all_states (ST &rest ST_ALL)
  (merge_all_states_in_list ST ST_ALL))

(defun merge_all_states_in_list (ST ST_ALL)
  (cond ((null ST_ALL) ST)
	((merge_all_states_in_list (merge_2_states ST (car ST_ALL))
				   (cdr ST_ALL)))))

(defun merge_2_states (ST ST1)
  (cond ((null ST1) ST)
	((merge_rulepar
	  (merge_varval
	   (merge_prolog
	    ST
	    ST1)
	   ST1)
	  ST1))))

; Append the prolog code of the state ST1 which is not contained
; in the ST to the ST.
(defun merge_prolog (ST ST1)
  (let ((RV (get_1st_diff_row2 (st_prolog ST)
			       (st_prolog ST1))))
    (cond ((null RV) ST)
	  ((mapcar #'(lambda (ROW) (append_code ST ROW)) RV))))
  ST)
 
(defun get_1st_diff_row2 (ROWS_LIST RET_ROWS_LIST)
  (cond ((or (null ROWS_LIST) (null RET_ROWS_LIST)) RET_ROWS_LIST)
	((not (equal (car ROWS_LIST) (car RET_ROWS_LIST))) RET_ROWS_LIST)
	((get_1st_diff_row2 (cdr ROWS_LIST) (cdr RET_ROWS_LIST)))))
  
; It merges st_varval list of the state ST1 to the state ST.
(defun merge_varval (ST ST1)
  (cond ((null (st_varval ST1)) ST)
	(t (let ((SYMBOL (car (st_varval ST1))) (TMP_SYMBOL)
		 (VALUE_OLD (getf (st_varval ST) (car (st_varval ST1)) NIL))
		 (VALUE_NEW (cadr (st_varval ST1))))
	     (cond ((equal NIL VALUE_OLD) ; There is no such variable in ST1.
		    (add_variable ST SYMBOL VALUE_NEW))
		   ; ST does NOT have the variable bound with a value
		   ; but ST1 does.
		   ((and (equal VALUE_OLD SYMBOL)
			 (not (equal VALUE_NEW SYMBOL)))
		    (set_variable ST SYMBOL VALUE_NEW))
		   ; The same variables in both states are bound with
		   ; differrent values.
		   ((and (not (equal VALUE_OLD VALUE_NEW))
			 (not (equal VALUE_OLD SYMBOL))
			 (not (equal VALUE_NEW SYMBOL)))
		    (setf TMP_SYMBOL (create_tmpvar ST))
		    (set_variable ST TMP_SYMBOL VALUE_NEW)
		    (append_code ST (list (variable_eval_mark SYMBOL)
					  " = "
					  (variable_eval_mark TMP_SYMBOL)))))
	     (remf (st_varval ST1) SYMBOL))
	   (merge_varval ST ST1)
)))

(defun merge_rulepar (ST ST1)
  (setf (st_rulepar ST) (st_rulepar ST1))
  ST)



; ----- PRINTING PROLOG OUTPUT FUNCTIONS -----

; Print prolog code in all states in the state_list.
(defun print_prolog (STATE_LIST)
  (mapcar #'(lambda (STATE)
	      (print_prolog_clause STATE (st_prolog STATE)))
	  STATE_LIST)
  (terpri)) ; should be in myformat or in print_prolog_clause


; Prints the fact or the rule.
; The rule consist from the list of "rows".
; Each row is represented by the list of "elements".
(defun print_prolog_clause (STATE ROWS_LIST &optional (ROW_NUMBER 1))
  (cond ((null ROWS_LIST) nil)
	(t (cond ((> ROW_NUMBER 1) (myformat "   ")))
	   (print_prolog_row STATE
			     (car ROWS_LIST)
			     (= ROW_NUMBER 1)
			     (null (cdr ROWS_LIST)))
	   (print_prolog_clause STATE
				(cdr ROWS_LIST)
				(1+ ROW_NUMBER)))))


; If the element is a cons cell, call the function which symbol is stored
; in car and with cdr as parameter. The STATE parameter is here only
; for handing over to the called functions.
(defun print_prolog_row (STATE ELEM_LIST IS_FIRST_ROW IS_LAST_ROW)
  (cond ((null ELEM_LIST) (cond (IS_LAST_ROW (myformat ".~%"))
				((cond (IS_FIRST_ROW (myformat " :-~%"))
				       ((myformat ",~%"))))))
	(t (cond ((consp (car ELEM_LIST)) (funcall (caar ELEM_LIST)
						   STATE (cdar ELEM_LIST)))
		 ((myformat (car ELEM_LIST))))
	   (print_prolog_row STATE
			     (cdr ELEM_LIST)
			     IS_FIRST_ROW
			     IS_LAST_ROW))))


(defun myformat (STRING)
  (format t (cond ((symbolp STRING) (symbol-name STRING))
		  ((numberp STRING) (princ-to-string STRING))
		  (t STRING))))


; Print the current value of the variable.
(defun print-value (STATE VARIABLE &optional (WRITE_BRACKETS t))
  (let ((VALUE (evaluate STATE VARIABLE)))
    (cond ((myconsp VALUE) (print-cons STATE VALUE WRITE_BRACKETS))
	  ((mynull VALUE) (print-nil))
	  ((myformat VALUE)))))

(defun print-value-or-number (STATE VARIABLE &optional (WRITE_BRACKETS t))
  (cond ((numberp VARIABLE) (myformat VARIABLE))
	((mynull VARIABLE) (print-nil))
	((print-value STATE VARIABLE WRITE_BRACKETS))))


(defun print-cons (STATE VALUE &optional (WRITE_BRACKETS t))
  (cond (WRITE_BRACKETS (myformat "[")))
  (print-value-or-number STATE (cadr VALUE))
  ; If the (cdr VALUE) is a cons cons cell, write comma `,'
  ; instead of pipe character `|' and brackets - `[' and `]'.
  ; [A|[B]] -> [A, B]
  (cond ((myconsp (evaluate STATE (caddr VALUE)))
	 (myformat ", ")
	 (print-value-or-number STATE (caddr VALUE) nil))
	((mynull (caddr VALUE)) nil)
	(t (myformat "|")
	   (print-value-or-number STATE (caddr VALUE))))
  (cond (WRITE_BRACKETS (myformat "]"))))


(defun print-nil ()
  (myformat "[]"))