My first lisp program.

mc.lisp

; Missionaries and Cannibals

;-------------------------------------------------------------------------------
; main method

( defmethod mc ()
  ( establish-operators )
  ( setup )
  ( solve )
)

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

( defclass node ()
  (
    ( name
      :accessor node-name
      :initarg :name
    )
    ( state
      :accessor node-state
      :initarg :state
    )
    ( parent
      :accessor node-parent
      :initarg :parent
    )
    ( operator
      :accessor node-operator
      :initarg :operator
    )
  )
)

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

( defmethod display ( ( n node ) )
  ( princ ( node-name n ) )
  ( write-string " " )
  ( if ( not ( rootp n ) )
    ( let ()
      ( princ ( node-name ( node-parent n ) ) )
      ( princ " " )
      ( display ( node-operator n ) )
    )
  )
  ;( terpri )
  ( display ( node-state n ) )
  nil
)

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

( defmethod display-e-node ( ( n node ) )
  ( write-line "E-NODE " ) ;( terpri )
  ( display n )
  nil
)

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

( defmethod rootp ( ( n node ) )
  ( eq ( node-name n ) 'root )
)

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

( defmethod exploredp ( ( n node ) )
  ( member-node-p n *explored* )
)

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

( defmethod member-node-p ( ( n node ) ( l list ) )
  ( cond
    (
      ( null l )
      nil
    )
    (
      ( equal-state-p ( node-state n ) ( node-state ( first l ) ) )
      t
    )
    ( t
      ( member-node-p n ( rest l ) )
    )
  )
)

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

( defclass bank ()
  (
    ( missionaries
      :accessor bank-missionaries
      :initarg :missionaries
    )
    ( cannibals
      :accessor bank-cannibals
      :initarg :cannibals
    )
    ( boat
      :accessor bank-boat
      :initarg :boat
    )
  )
)

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

( defmethod display ( ( b bank ) )
  ( format t "      missionaires=~a" ( bank-missionaries b ) )
  ( format t " cannibals=~a" ( bank-cannibals b ) )
  ( format t " boat=~a" ( bank-boat b ) )
)

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

( defmethod boatp ( ( b bank ) )
  (not ( eq ( bank-boat b ) nil ) )
)

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

( defclass state ()
  (
    ( left-bank
	:accessor state-left-bank
	:initarg :left-bank
    )
    ( right-bank
	:accessor state-right-bank
	:initarg :right-bank
    )
  )
)

;-------------------------------------------------------------------------------
; display the state

( defmethod display ( ( s state ) )
  ( display ( state-left-bank s ) )
  ( display ( state-right-bank s ) )
  ( terpri )
  nil
)

;-------------------------------------------------------------------------------
; checks if the given state is the goal state

( defmethod goalp ( ( s state ) )
  ( and
    ( = ( length ( bank-missionaries ( state-left-bank s ) ) ) 0 )
    ( = ( length ( bank-cannibals ( state-left-bank s ) ) ) 0 )
    ( = ( length ( bank-boat ( state-left-bank s ) ) ) 0 )
  )
)

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

( defmethod feastp ( ( s state ) )
  ( or
    ( and
      ( not ( null ( bank-missionaries ( state-left-bank s ) ) ) )
      ( <
        ( length ( bank-missionaries ( state-left-bank s ) ) )
        ( length ( bank-cannibals ( state-left-bank s ) ) )
      )
    )
    ( and
      ( not ( null ( bank-missionaries ( state-right-bank s ) ) ) )
      ( <
        ( length ( bank-missionaries ( state-right-bank s ) ) )
        ( length ( bank-cannibals ( state-right-bank s ) ) )
      )
    )
  )
)

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

( defmethod copy-state ( ( s state ) &aux lb rb )
  ( setf lb ( make-instance 'bank
      :missionaries ( bank-missionaries ( state-left-bank s ) )
      :cannibals ( bank-cannibals ( state-left-bank s ) )
      :boat ( bank-boat ( state-left-bank s ) )
    )
  )
  ( setf rb ( make-instance 'bank
      :missionaries ( bank-missionaries ( state-right-bank s ) )
      :cannibals ( bank-cannibals ( state-right-bank s ) )
      :boat ( bank-boat ( state-right-bank s ) )
    )
  )
  ( make-instance 'state
    :left-bank  lb
    :right-bank rb
  )
)

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

( defmethod equal-state-p ( ( s1 state ) ( s2 state ) )
  ( and
    ( =
      ( length ( bank-missionaries ( state-left-bank s1 ) ) )
      ( length ( bank-missionaries ( state-left-bank s2 ) ) )
    )
    ( =
      ( length ( bank-missionaries ( state-right-bank s1 ) ) )
      ( length ( bank-missionaries ( state-right-bank s2 ) ) )
    )
    ( =
      ( length ( bank-cannibals ( state-left-bank s1 ) ) )
      ( length ( bank-cannibals ( state-left-bank s2 ) ) )
    )
    ( =
      ( length ( bank-cannibals ( state-right-bank s1 ) ) )
      ( length ( bank-cannibals ( state-right-bank s2 ) ) )
    )
    ( eq
      ( bank-boat ( state-left-bank s1 ) )
      ( bank-boat ( state-left-bank s2 ) )
    )
    ( eq
      ( bank-boat ( state-right-bank s1 ) )
      ( bank-boat ( state-right-bank s2 ) )
    )
  )
)

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

( defclass operator ()
  (
    ( name
	:accessor operator-name
	:initarg :name
    )
    ( precondition
	:accessor operator-precondition
	:initarg :precondition
    )
    ( description
	:accessor operator-description
	:initarg :description
    )
  )
)

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

( defmethod describe-operators ()
  ( mapcar #'describe-operator *operator-list* )
  nil
)

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

( defmethod describe-operator ( ( op operator ) )
  ( format t "Operator name: ~A~%" ( operator-name op ) )
  ( format t "Precondition: ~A~%" ( operator-precondition op ) )
  ( format t "Description: ~A~%~%" ( operator-description op ) )
)

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

( defmethod display ( ( op operator ) )
  ( prin1 ( operator-name op ) )
)

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

( defmethod establish-operators ()
  ( setf *lr-m*
    ( make-instance 'operator
      :name 'lr-m
      :precondition "There is a M on the left bank"
      :description "Move a missionary from the left bank to the right bank"
    )
  )
  ( setf *lr-c*
    ( make-instance 'operator
      :name 'lr-c
      :precondition "There is a C on the left bank"
      :description "Move a cannibal from the left bank to the right bank"
    )
  )
  ( setf *lr-mm*
    ( make-instance 'operator
      :name 'lr-mm
      :precondition "There are two Ms on the left bank"
      :description "Move two missionaries from the left bank to the right bank"
    )
  )
  ( setf *lr-cc*
    ( make-instance 'operator
      :name 'lr-cc
      :precondition "There are two Cs on the left bank"
      :description "Move two cannibals from the left bank to the right bank"
    )
  )
  ( setf *lr-cm*
    ( make-instance 'operator
      :name 'lr-cm
      :precondition "There is an M and a C on the left bank"
      :description "Move a missionary and a cannibal from the left bank to the right bank"
    )
  )
  ( setf *rl-m*
    ( make-instance 'operator
      :name 'rl-m
      :precondition "There is a M on the right bank"
      :description "Move one missionary from the right bank to the left bank"
    )
  )
  ( setf *rl-c*
    ( make-instance 'operator
      :name 'rl-c
      :precondition "There is a C on the right bank"
      :description "Move one cannibal from the right bank to the left bank"
    )
  )
  ( setf *rl-mm*
    ( make-instance 'operator
      :name 'rl-mm
      :precondition "There are two Ms on the right bank"
      :description "Move two missionaries from the right bank to the left bank"
    )
  )
  ( setf *rl-cc*
    ( make-instance 'operator
      :name 'rl-cc
      :precondition "There are two Cs on the right bank"
      :description "Move two cannibals from the right bank to the left bank"
    )
  )
  ( setf *rl-cm*
    ( make-instance 'operator
      :name 'rl-cm
      :precondition "There is an M and a C on the right bank"
      :description "Move a missionary and cannibals from right bank to the left bank"
    )
  )
  ( setf *operator-list*
    ( list *lr-m* *lr-c* *lr-mm* *lr-cc* *lr-cm*
           *rl-m* *rl-c* *rl-mm* *rl-cc* *rl-cm*
    )
  )
  nil
)

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

( defmethod applicablep ( ( op operator ) ( s state ) )
  ;( format t "----- ~A~%" ( operator-name op ) )
  ( cond
    ( ( eq ( operator-name op ) 'lr-m  ) ( applicable-lr-m-p  s ) )
    ( ( eq ( operator-name op ) 'lr-c  ) ( applicable-lr-c-p  s ) )
    ( ( eq ( operator-name op ) 'lr-mm ) ( applicable-lr-mm-p s ) )
    ( ( eq ( operator-name op ) 'lr-cc ) ( applicable-lr-cc-p s ) )
    ( ( eq ( operator-name op ) 'lr-cm ) ( applicable-lr-cm-p s ) )
    ( ( eq ( operator-name op ) 'rl-m  ) ( applicable-rl-m-p  s ) )
    ( ( eq ( operator-name op ) 'rl-c  ) ( applicable-rl-c-p  s ) )
    ( ( eq ( operator-name op ) 'rl-mm ) ( applicable-rl-mm-p s ) )
    ( ( eq ( operator-name op ) 'rl-cc ) ( applicable-rl-cc-p s ) )
    ( ( eq ( operator-name op ) 'rl-cm ) ( applicable-rl-cm-p s ) )
  )
)

( defmethod applicable-lr-m-p ( ( s state ) )
  ( and
    ( > ( length ( bank-missionaries ( state-left-bank s ) ) ) 0 )
    ( eq 'b ( bank-boat ( state-left-bank s ) ) )
  )
)

( defmethod applicable-lr-mm-p ( ( s state ) )
  ( and
    ( > ( length ( bank-missionaries ( state-left-bank s ) ) ) 1 )
    ( eq 'b ( bank-boat ( state-left-bank s ) ) )
  )
)

( defmethod applicable-lr-c-p ( ( s state ) )
  ( and
    ( > ( length ( bank-cannibals ( state-left-bank s ) ) ) 0 )
    ( eq 'b ( bank-boat ( state-left-bank s ) ) )
  )
)

( defmethod applicable-lr-cc-p ( ( s state ) )
  ( and
    ( > ( length ( bank-cannibals ( state-left-bank s ) ) ) 1 )
    ( not ( null ( bank-boat ( state-left-bank s ) ) ) )
  )
)

( defmethod applicable-lr-cm-p ( ( s state ) )
  ( and
    ( and ( applicable-lr-m-p s ) ( applicable-lr-c-p s ) )
    ( not ( null ( bank-boat ( state-left-bank s ) ) ) )
  )
)

( defmethod applicable-rl-m-p ( ( s state ) )
  ( and
    ( > ( length ( bank-missionaries ( state-right-bank s ) ) ) 0 )
    ( not ( null ( bank-boat ( state-right-bank s ) ) ) )
  )
)

( defmethod applicable-rl-mm-p ( ( s state ) )
  ( and
    ( > ( length ( bank-missionaries ( state-right-bank s ) ) ) 1 )
    ( not ( null ( bank-boat ( state-right-bank s ) ) ) )
  )
)

( defmethod applicable-rl-c-p ( ( s state ) )
  ( and
    ( > ( length ( bank-cannibals ( state-right-bank s ) ) ) 0 )
    ( not ( null ( bank-boat ( state-right-bank s ) ) ) )
  )
)

( defmethod applicable-rl-cc-p ( ( s state ) )
  ( and
    ( > ( length ( bank-cannibals ( state-right-bank s ) ) ) 1 )
    ( not ( null ( bank-boat ( state-right-bank s ) ) ) )
  )
)

( defmethod applicable-rl-cm-p ( ( s state ) )
  ( and
    ( and ( applicable-rl-c-p s ) ( applicable-rl-m-p s ) )
    ( not ( null ( bank-boat ( state-right-bank s ) ) ) )
  )
)

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

( defmethod setup ( &aux root lb rb istate )
  ;; establish root node
  ( setf lb
    ( make-instance 'bank
      :missionaries '( m m m )
      :cannibals '( c c c )
      :boat 'b
    )
  )
  ( setf rb
    ( make-instance 'bank
      :missionaries '()
      :cannibals '()
      :boat nil
    )
  )
  ( setf istate
    ( make-instance 'state
      :left-bank lb
      :right-bank rb
    )
  )
  ( setf root
    ( make-instance 'node
      :state istate
      :name 'root
      :parent nil
    )
  )
  ; initialize list of unexplored nodes
  ( setf *unexplored* ( list root ) )
  ; initialize list of explored nodes
  ( setf *explored* () )
  ; get ready to create good names
  ( setf *ng* ( make-instance 'name-generator :prefix "N" ) )
)

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

( defmethod solve ( &aux kids e-node )
  ( if *tracing-search*
    ( let ()
      ( write-line ">>>>>>>>>>>>>> Solve <<<<<<<<<<<<<<<" )
      ;( display-explored-nodes )
      ( display-unexplored-nodes )
    )
  )
  ( cond
    ( ( null *unexplored* )
      ( write-line "There is no solution." )
      ( return-from solve nil )
    )
  )
  ( setf e-node ( pop *unexplored* ) )
  ( if *tracing-search* ( display-e-node e-node ) )
  ( cond
    ( ( goalp ( node-state e-node ) )
      ( display-solution e-node )
    )
    ( ( and ( feastp ( node-state e-node ) ) *tracing-search* )
      ( write-line "This is a feast state" )
      ( solve )
    )
    ( ( exploredp e-node )
      ( solve )
    )
    ( t
      ( push e-node *explored* )
      ( setf kids ( children-of e-node ) )
      ( setf *unexplored* ( append *unexplored* kids ) )
      ( solve )
    )
  )
  nil
)

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

( defmethod children-of ( ( e-node node ) &aux kids )
  ( if ( applicablep *lr-m*  ( node-state e-node ) ) ( push ( child-of e-node *lr-m*  ) kids ) )
  ( if ( applicablep *lr-c*  ( node-state e-node ) ) ( push ( child-of e-node *lr-c*  ) kids ) )
  ( if ( applicablep *lr-mm* ( node-state e-node ) ) ( push ( child-of e-node *lr-mm* ) kids ) )
  ( if ( applicablep *lr-cc* ( node-state e-node ) ) ( push ( child-of e-node *lr-cc* ) kids ) )
  ( if ( applicablep *lr-cm* ( node-state e-node ) ) ( push ( child-of e-node *lr-cm* ) kids ) )
  ( if ( applicablep *rl-m*  ( node-state e-node ) ) ( push ( child-of e-node *rl-m*  ) kids ) )
  ( if ( applicablep *rl-c*  ( node-state e-node ) ) ( push ( child-of e-node *rl-c*  ) kids ) )
  ( if ( applicablep *rl-mm* ( node-state e-node ) ) ( push ( child-of e-node *rl-mm* ) kids ) )
  ( if ( applicablep *rl-cc* ( node-state e-node ) ) ( push ( child-of e-node *rl-cc* ) kids ) )
  ( if ( applicablep *rl-cm* ( node-state e-node ) ) ( push ( child-of e-node *rl-cm* ) kids ) )
  kids
)

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

( defmethod child-of ( ( n node ) ( o operator ) &aux c new-node )
  ( setf new-node ( make-instance 'node ) )
  ( setf ( node-name new-node ) ( next *ng* ) )
  ( setf ( node-parent new-node ) n )
  ( setf ( node-operator new-node ) o )
  ( setf c ( copy-state ( node-state n ) ) )
  ( apply-operator o c )
  ( setf ( node-state new-node ) c ) 
  new-node
)

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

( defmethod apply-operator ( ( o operator ) ( c state ) )
  ( setf lb ( state-left-bank c ) )
  ( setf rb ( state-right-bank c ) )
  ( cond
    ( ( eq ( operator-name o ) 'lr-m  ) ( move-m lb rb ) )
    ( ( eq ( operator-name o ) 'lr-c  ) ( move-c lb rb ) )
    ( ( eq ( operator-name o ) 'lr-mm ) ( move-m lb rb ) ( move-m lb rb ) )
    ( ( eq ( operator-name o ) 'lr-cc ) ( move-c lb rb ) ( move-c lb rb ) )
    ( ( eq ( operator-name o ) 'lr-cm ) ( move-c lb rb ) ( move-m lb rb ) )
    ( ( eq ( operator-name o ) 'rl-m  ) ( move-m rb lb ) )
    ( ( eq ( operator-name o ) 'rl-c  ) ( move-c rb lb ) )
    ( ( eq ( operator-name o ) 'rl-mm ) ( move-m rb lb ) ( move-m rb lb ) )
    ( ( eq ( operator-name o ) 'rl-cc ) ( move-c rb lb ) ( move-c rb lb ) )
    ( ( eq ( operator-name o ) 'rl-cm ) ( move-c rb lb ) ( move-m rb lb ) )
  )
  ( setf ( state-left-bank c ) lb )
  ( setf ( state-right-bank c ) rb )
  nil
)

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

( defmethod move-m ( ( from bank ) ( dest bank ) )
  ( push 'm ( bank-missionaries dest ) )
  ( pop ( bank-missionaries from ) )
  ( cond
    ( ( equal 'b ( bank-boat from ) )
      ( setf ( bank-boat from ) nil ) 
      ( setf ( bank-boat dest ) 'b )
    )
  )
  nil
)

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

( defmethod move-c ( ( from bank ) ( dest bank ) )
  ( push 'c ( bank-cannibals dest ) )
  ( pop ( bank-cannibals from ) )
  ( cond
    ( ( eq 'b ( bank-boat from ) )
      ( setf ( bank-boat from ) nil ) 
      ( setf ( bank-boat dest ) 'b )
    )
  )
  nil
)

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

( defclass name-generator ()
  (
    ( prefix
      :accessor name-generator-prefix
      :initarg :prefix
      :initform "name"
    )
    ( nr
      :accessor name-generator-nr
      :initform 0
    )
  )
)

( defmethod next ( ( ng name-generator ) )
  ( setf ( name-generator-nr ng ) ( + 1 ( name-generator-nr ng ) ) )
  ( concatenate 'string
    ( name-generator-prefix ng )
    ( write-to-string ( name-generator-nr ng ) )
  )
)

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

( defmethod display-solution ( ( n node ) )
  ( cond
    ( ( rootp n )
      ( terpri )
    )
    ( t
      ( display-solution ( node-parent n ) )
      ( princ ( operator-description ( node-operator n ) ) )
      ( terpri )
    )
  )
  nil
)

( defmethod display-explored-nodes ()
  ( prin1 'explored ) ( terpri ) ( terpri )
  ( mapcar #'display *explored* )
  nil
)

( defmethod display-unexplored-nodes ()
  ( prin1 'unexplored ) ( terpri )
  ( mapcar #'display *unexplored* )
  ( terpri )
  nil
)

;-------------------------------------------------------------------------------
; to trace the search or no to trace the search

( setf *tracing-search* t )