{-# language DisambiguateRecordFields #-}

-- | This module is an example of using @fast-downward@ to solve a problem of
-- transporting balls between rooms using a robot. See the source listing for
-- this file for the full example, and see
-- <https://ocharles.org.uk/blog/posts/2018-12-25-fast-downward.html> for a
-- detailed walk through.

module FastDownward.Examples.Gripper where

import Control.Monad
import qualified FastDownward.Exec as Exec
import FastDownward


data Room = RoomA | RoomB
  deriving (Room -> Room -> Bool
(Room -> Room -> Bool) -> (Room -> Room -> Bool) -> Eq Room
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Room -> Room -> Bool
$c/= :: Room -> Room -> Bool
== :: Room -> Room -> Bool
$c== :: Room -> Room -> Bool
Eq, Eq Room
Eq Room
-> (Room -> Room -> Ordering)
-> (Room -> Room -> Bool)
-> (Room -> Room -> Bool)
-> (Room -> Room -> Bool)
-> (Room -> Room -> Bool)
-> (Room -> Room -> Room)
-> (Room -> Room -> Room)
-> Ord Room
Room -> Room -> Bool
Room -> Room -> Ordering
Room -> Room -> Room
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Room -> Room -> Room
$cmin :: Room -> Room -> Room
max :: Room -> Room -> Room
$cmax :: Room -> Room -> Room
>= :: Room -> Room -> Bool
$c>= :: Room -> Room -> Bool
> :: Room -> Room -> Bool
$c> :: Room -> Room -> Bool
<= :: Room -> Room -> Bool
$c<= :: Room -> Room -> Bool
< :: Room -> Room -> Bool
$c< :: Room -> Room -> Bool
compare :: Room -> Room -> Ordering
$ccompare :: Room -> Room -> Ordering
$cp1Ord :: Eq Room
Ord, Int -> Room -> ShowS
[Room] -> ShowS
Room -> String
(Int -> Room -> ShowS)
-> (Room -> String) -> ([Room] -> ShowS) -> Show Room
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Room] -> ShowS
$cshowList :: [Room] -> ShowS
show :: Room -> String
$cshow :: Room -> String
showsPrec :: Int -> Room -> ShowS
$cshowsPrec :: Int -> Room -> ShowS
Show)


adjacent :: Room -> Room
adjacent :: Room -> Room
adjacent Room
RoomA = Room
RoomB
adjacent Room
RoomB = Room
RoomA


data BallLocation = InRoom Room | InGripper
  deriving (BallLocation -> BallLocation -> Bool
(BallLocation -> BallLocation -> Bool)
-> (BallLocation -> BallLocation -> Bool) -> Eq BallLocation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BallLocation -> BallLocation -> Bool
$c/= :: BallLocation -> BallLocation -> Bool
== :: BallLocation -> BallLocation -> Bool
$c== :: BallLocation -> BallLocation -> Bool
Eq, Eq BallLocation
Eq BallLocation
-> (BallLocation -> BallLocation -> Ordering)
-> (BallLocation -> BallLocation -> Bool)
-> (BallLocation -> BallLocation -> Bool)
-> (BallLocation -> BallLocation -> Bool)
-> (BallLocation -> BallLocation -> Bool)
-> (BallLocation -> BallLocation -> BallLocation)
-> (BallLocation -> BallLocation -> BallLocation)
-> Ord BallLocation
BallLocation -> BallLocation -> Bool
BallLocation -> BallLocation -> Ordering
BallLocation -> BallLocation -> BallLocation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BallLocation -> BallLocation -> BallLocation
$cmin :: BallLocation -> BallLocation -> BallLocation
max :: BallLocation -> BallLocation -> BallLocation
$cmax :: BallLocation -> BallLocation -> BallLocation
>= :: BallLocation -> BallLocation -> Bool
$c>= :: BallLocation -> BallLocation -> Bool
> :: BallLocation -> BallLocation -> Bool
$c> :: BallLocation -> BallLocation -> Bool
<= :: BallLocation -> BallLocation -> Bool
$c<= :: BallLocation -> BallLocation -> Bool
< :: BallLocation -> BallLocation -> Bool
$c< :: BallLocation -> BallLocation -> Bool
compare :: BallLocation -> BallLocation -> Ordering
$ccompare :: BallLocation -> BallLocation -> Ordering
$cp1Ord :: Eq BallLocation
Ord, Int -> BallLocation -> ShowS
[BallLocation] -> ShowS
BallLocation -> String
(Int -> BallLocation -> ShowS)
-> (BallLocation -> String)
-> ([BallLocation] -> ShowS)
-> Show BallLocation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BallLocation] -> ShowS
$cshowList :: [BallLocation] -> ShowS
show :: BallLocation -> String
$cshow :: BallLocation -> String
showsPrec :: Int -> BallLocation -> ShowS
$cshowsPrec :: Int -> BallLocation -> ShowS
Show)


data GripperState = Empty | HoldingBall
  deriving (GripperState -> GripperState -> Bool
(GripperState -> GripperState -> Bool)
-> (GripperState -> GripperState -> Bool) -> Eq GripperState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GripperState -> GripperState -> Bool
$c/= :: GripperState -> GripperState -> Bool
== :: GripperState -> GripperState -> Bool
$c== :: GripperState -> GripperState -> Bool
Eq, Eq GripperState
Eq GripperState
-> (GripperState -> GripperState -> Ordering)
-> (GripperState -> GripperState -> Bool)
-> (GripperState -> GripperState -> Bool)
-> (GripperState -> GripperState -> Bool)
-> (GripperState -> GripperState -> Bool)
-> (GripperState -> GripperState -> GripperState)
-> (GripperState -> GripperState -> GripperState)
-> Ord GripperState
GripperState -> GripperState -> Bool
GripperState -> GripperState -> Ordering
GripperState -> GripperState -> GripperState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: GripperState -> GripperState -> GripperState
$cmin :: GripperState -> GripperState -> GripperState
max :: GripperState -> GripperState -> GripperState
$cmax :: GripperState -> GripperState -> GripperState
>= :: GripperState -> GripperState -> Bool
$c>= :: GripperState -> GripperState -> Bool
> :: GripperState -> GripperState -> Bool
$c> :: GripperState -> GripperState -> Bool
<= :: GripperState -> GripperState -> Bool
$c<= :: GripperState -> GripperState -> Bool
< :: GripperState -> GripperState -> Bool
$c< :: GripperState -> GripperState -> Bool
compare :: GripperState -> GripperState -> Ordering
$ccompare :: GripperState -> GripperState -> Ordering
$cp1Ord :: Eq GripperState
Ord, Int -> GripperState -> ShowS
[GripperState] -> ShowS
GripperState -> String
(Int -> GripperState -> ShowS)
-> (GripperState -> String)
-> ([GripperState] -> ShowS)
-> Show GripperState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GripperState] -> ShowS
$cshowList :: [GripperState] -> ShowS
show :: GripperState -> String
$cshow :: GripperState -> String
showsPrec :: Int -> GripperState -> ShowS
$cshowsPrec :: Int -> GripperState -> ShowS
Show)


type Ball = Var BallLocation


type Gripper = Var GripperState


data Action = PickUpBall | SwitchRooms | DropBall
  deriving (Int -> Action -> ShowS
[Action] -> ShowS
Action -> String
(Int -> Action -> ShowS)
-> (Action -> String) -> ([Action] -> ShowS) -> Show Action
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Action] -> ShowS
$cshowList :: [Action] -> ShowS
show :: Action -> String
$cshow :: Action -> String
showsPrec :: Int -> Action -> ShowS
$cshowsPrec :: Int -> Action -> ShowS
Show)


problem :: Problem (SolveResult Action)
problem :: Problem (SolveResult Action)
problem = do
  [Var BallLocation]
balls <- Int -> Problem (Var BallLocation) -> Problem [Var BallLocation]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 (BallLocation -> Problem (Var BallLocation)
forall a. Ord a => a -> Problem (Var a)
newVar (Room -> BallLocation
InRoom Room
RoomA))
  Var Room
robotLocation <- Room -> Problem (Var Room)
forall a. Ord a => a -> Problem (Var a)
newVar Room
RoomA
  [Var GripperState]
grippers <- Int -> Problem (Var GripperState) -> Problem [Var GripperState]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (GripperState -> Problem (Var GripperState)
forall a. Ord a => a -> Problem (Var a)
newVar GripperState
Empty)

  let
    pickUpBallWithGrippper :: Ball -> Gripper -> Effect Action
    pickUpBallWithGrippper :: Var BallLocation -> Var GripperState -> Effect Action
pickUpBallWithGrippper Var BallLocation
b Var GripperState
gripper = do
      GripperState
Empty <- Var GripperState -> Effect GripperState
forall a. Ord a => Var a -> Effect a
readVar Var GripperState
gripper

      Room
robotRoom <- Var Room -> Effect Room
forall a. Ord a => Var a -> Effect a
readVar Var Room
robotLocation
      BallLocation
ballLocation <- Var BallLocation -> Effect BallLocation
forall a. Ord a => Var a -> Effect a
readVar Var BallLocation
b
      Bool -> Effect ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BallLocation
ballLocation BallLocation -> BallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== Room -> BallLocation
InRoom Room
robotRoom)

      Var BallLocation -> BallLocation -> Effect ()
forall a. Ord a => Var a -> a -> Effect ()
writeVar Var BallLocation
b BallLocation
InGripper
      Var GripperState -> GripperState -> Effect ()
forall a. Ord a => Var a -> a -> Effect ()
writeVar Var GripperState
gripper GripperState
HoldingBall

      Action -> Effect Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
PickUpBall


    moveRobotToAdjacentRoom :: Effect Action
    moveRobotToAdjacentRoom :: Effect Action
moveRobotToAdjacentRoom = do
      Var Room -> (Room -> Room) -> Effect ()
forall a. Ord a => Var a -> (a -> a) -> Effect ()
modifyVar Var Room
robotLocation Room -> Room
adjacent
      Action -> Effect Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
SwitchRooms


    dropBall :: Ball -> Gripper -> Effect Action
    dropBall :: Var BallLocation -> Var GripperState -> Effect Action
dropBall Var BallLocation
b Var GripperState
gripper = do
      GripperState
HoldingBall <- Var GripperState -> Effect GripperState
forall a. Ord a => Var a -> Effect a
readVar Var GripperState
gripper
      BallLocation
InGripper <- Var BallLocation -> Effect BallLocation
forall a. Ord a => Var a -> Effect a
readVar Var BallLocation
b

      Room
robotRoom <- Var Room -> Effect Room
forall a. Ord a => Var a -> Effect a
readVar Var Room
robotLocation
      Var BallLocation -> BallLocation -> Effect ()
forall a. Ord a => Var a -> a -> Effect ()
writeVar Var BallLocation
b (Room -> BallLocation
InRoom Room
robotRoom)

      Var GripperState -> GripperState -> Effect ()
forall a. Ord a => Var a -> a -> Effect ()
writeVar Var GripperState
gripper GripperState
Empty

      Action -> Effect Action
forall (m :: * -> *) a. Monad m => a -> m a
return Action
DropBall


  SearchConfiguration
-> [Effect Action] -> [Test] -> Problem (SolveResult Action)
forall a.
Show a =>
SearchConfiguration
-> [Effect a] -> [Test] -> Problem (SolveResult a)
solve
    SearchConfiguration
Exec.bjolp
    ( [ Var BallLocation -> Var GripperState -> Effect Action
pickUpBallWithGrippper Var BallLocation
b Var GripperState
g | Var BallLocation
b <- [Var BallLocation]
balls, Var GripperState
g <- [Var GripperState]
grippers ]
        [Effect Action] -> [Effect Action] -> [Effect Action]
forall a. [a] -> [a] -> [a]
++ [ Var BallLocation -> Var GripperState -> Effect Action
dropBall Var BallLocation
b Var GripperState
g | Var BallLocation
b <- [Var BallLocation]
balls, Var GripperState
g <- [Var GripperState]
grippers ]
        [Effect Action] -> [Effect Action] -> [Effect Action]
forall a. [a] -> [a] -> [a]
++ [ Effect Action
moveRobotToAdjacentRoom ]
    )
    [ Var BallLocation
b Var BallLocation -> BallLocation -> Test
forall a. Ord a => Var a -> a -> Test
?= Room -> BallLocation
InRoom Room
RoomB | Var BallLocation
b <- [Var BallLocation]
balls ]


main :: IO ()
main :: IO ()
main = do
  SolveResult Action
res <- Problem (SolveResult Action) -> IO (SolveResult Action)
forall (m :: * -> *) a. MonadIO m => Problem a -> m a
runProblem Problem (SolveResult Action)
problem
  case SolveResult Action
res of
    Solved Solution Action
plan -> do
      String -> IO ()
putStrLn String
"Found a plan!"
      (Int -> Action -> IO ()) -> [Int] -> [Action] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_
        ( \Int
i Action
step -> String -> IO ()
putStrLn ( Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Action -> String
forall a. Show a => a -> String
show Action
step ) )
        [ Int
1::Int .. ]
        ( Solution Action -> [Action]
forall a. Solution a -> [a]
totallyOrderedPlan Solution Action
plan )

    SolveResult Action
_ ->
      String -> IO ()
putStrLn String
"Couldn't find a plan!"