{-# LANGUAGE ScopedTypeVariables,GeneralizedNewtypeDeriving #-}
{-
  This program is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.
  
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
  
  You should have received a copy of the GNU General Public License
  along with this program.  If not, see <http://www.gnu.org/licenses/>.
 -}

module Main (main) where{
import Array;
import System;
import Char;
import IO;
import Control.Monad.State;
import Control.Exception;
import Monad;
import Random;
import Data.List;
import qualified Data.Set as Set;
import qualified Data.Map as Map;
import Maybe;
import Data.Array.ST;
import Control.Monad.ST;

main :: IO(());
main = (do{
  (setStdGen (mkStdGen 1));
  (getArgs >>= (\lambda_case_var ->case lambda_case_var of {
  ["nothing"]-> (return ());
  ["show-chords", (num_actions )]-> (show_chords (read num_actions))
}));
});
map_tuple :: (a -> b) -> (a, a) -> (b, b);
map_tuple fn x = ((fn (fst x)), (fn (snd x)));
apply_first :: (a -> b) -> (a, c) -> (b, c);
apply_first fn x = ((fn (fst x)), (snd x));
apply_second :: (a -> b) -> (c, a) -> (c, b);
apply_second fn x = ((fst x), (fn (snd x)));
zip_check_same_length :: [](a) -> [](b) -> []((a, b));
zip_check_same_length x1 x2 = (case (x1, x2) of {
  (([] ), ([] ))-> [];
  (((:) (a ) (arest )), ((:) (b ) (brest )))-> ((:) (a, b) (zip_check_same_length arest brest))
});
zipWith_check_same_length :: (a -> b -> c) -> [](a) -> [](b) -> [](c);
zipWith_check_same_length f x1 x2 = (case (x1, x2) of {
  (([] ), ([] ))-> [];
  (((:) (a ) (arest )), ((:) (b ) (brest )))-> ((:) (f a b) (zipWith_check_same_length f arest brest))
});
zip_map :: (a -> b) -> [](a) -> []((a, b));
zip_map f l = (zip l (map f l));
flip_tuple :: (a, b) -> (b, a);
flip_tuple x = ((snd x), (fst x));
show_list :: (Show (a)) => [](a) -> IO(());
show_list l = (putStr(unlines((map show)(l))));
compare_zipped :: (Ord (b)) => ((a, b) -> (a, b) -> Ordering);
compare_zipped = (curry ((uncurry compare) . (map_tuple snd)));
take_while_plus :: (a -> Bool) -> [](a) -> ([](a), Maybe(a));
take_while_plus p l = (case l of {
  ([] )-> ([], Nothing);
  ((:) (h ) (t ))-> (case (p h) of {
  (False )-> ([], (Just h));
  (_ )-> (let {
answer = (take_while_plus p t)
}
 in (((:) h (fst(answer))), (snd answer)))
})
});
random_from_list :: [](a) -> IO(a);
random_from_list l = ((getStdRandom(randomR((0, (pred(length(l))))))) >>= (return . ((!!) l)));
rcs_code :: String;
rcs_code = "$Id: chords.ll,v 1.10 2010/12/05 11:58:07 kenta Exp kenta $";
data Button  = Thumb(Tposition) | Finger(Fnumber) deriving (Show, Eq);
data Direction  = Up | Down deriving (Show, Eq);
data Command  = Key(Hand)(Button)(Direction) | Beat deriving (Show, Eq);
newtype Tposition  = Tposition(Int) deriving (Show, Eq, Ord, Ix);
data Hstate  = Hstate(Tstate)(Fstate) deriving (Show, Eq);
type Tstate  = Array(Hand)(Maybe(Tposition));
newtype Hand  = Hand(Int) deriving (Eq, Ord, Show, Ix);
type Hand_finger  = (Hand, Fnumber);
type Fstate  = Array(Hand_finger)(Direction);
newtype Fnumber  = Fnumber(Int) deriving (Eq, Ord, Show, Ix);
t_bounds :: (Tposition, Tposition);
t_bounds = ((Tposition 1), (Tposition 2));
f_bounds :: (Hand_finger, Hand_finger);
f_bounds = (((fst h_bounds), (Fnumber 1)), ((snd h_bounds), (Fnumber 2)));
h_bounds :: (Hand, Hand);
h_bounds = ((Hand 1), (Hand 2));
tmoves_one_hand :: Hand -> Maybe(Tposition) -> [](Command);
tmoves_one_hand hand old = (case old of {
  (Just p)-> [(Key hand (Thumb p) Up)];
  _ -> (do{
  t :: Tposition <- all_thumbs;
  (return (Key hand (Thumb t) Down));
})
});
all_thumbs :: [](Tposition);
all_thumbs = (range t_bounds);
flip_dir :: Direction -> Direction;
flip_dir d = (case d of {
  Up-> Down;
  Down-> Up
});
finger_moves :: Fstate -> [](Command);
finger_moves fs = (do{
  ((hand, finger), dir) :: (Hand_finger, Direction) <- (assocs fs);
  (return (Key hand (Finger finger) (flip_dir dir)));
});
thumb_moves :: Tstate -> [](Command);
thumb_moves ts = (do{
  (hand, thumb) :: (Hand, Maybe(Tposition)) <- (assocs ts);
  (tmoves_one_hand hand thumb);
});
empty_thumb :: Tstate;
empty_thumb = (listArray h_bounds (repeat Nothing));
empty_fingers :: Fstate;
empty_fingers = (listArray f_bounds (repeat Up));
empty_hand :: Hstate;
empty_hand = (Hstate empty_thumb empty_fingers);
ma :: (Ix (i)) => Array(i)(v) -> i -> v -> Array(i)(v);
ma a x y = ((//) a [(x, y)]);
fguard :: (Monad (m)) => Bool -> m(());
fguard pred = (case pred of {
  True-> (return ());
  False-> (fail "fail")
});
execute :: (Monad (m)) => Command -> Hstate -> m(Hstate);
execute c (Hstate thumb finger) = (case c of {
  Beat-> (return (Hstate thumb finger));
  (Key hand button dir)-> (case (button, dir) of {
  ((Thumb t), Down)-> (do{
  (fguard(isNothing(((!) thumb)(hand))));
  (return (Hstate (ma thumb hand (Just t)) finger));
});
  ((Thumb t), Up)-> (do{
  (fguard(isJust(((!) thumb)(hand))));
  (return (Hstate (ma thumb hand Nothing) finger));
});
  ((Finger f), newstate)-> (do{
  let {
hf :: Hand_finger;
hf = (hand, f)
};
  (fguard(((/=) newstate)(((!) finger)(hf))));
  (return (Hstate thumb (ma finger hf newstate)));
})
})
});
all_moves :: Hstate -> [](Command);
all_moves (Hstate t f) = ((:) Beat ((++) (finger_moves f) (thumb_moves t)));
type Mstate a = State(Maybe(Hstate))(a);
execute_in_monad :: Command -> Mstate(());
execute_in_monad c = (get >>= (put . (execute_out_monad c)));
execute_out_monad :: (Monad (m)) => Command -> m(Hstate) -> m(Hstate);
execute_out_monad c oldm = (oldm >>= (execute c));
run_through :: [](Command) -> Maybe(Hstate);
run_through c = (execState (mapM_ execute_in_monad c) (Just empty_hand));
do_one :: Hstate -> []((Hstate, Command));
do_one x = (do{
  move :: Command <- (all_moves x);
  (return ((fromJust (execute move x)), move));
});
do_several :: Int -> Hstate -> []([](Command));
do_several n x = (case (compare n 0) of {
  EQ-> (return []);
  GT-> (do{
  (new_state, did_move) :: (Hstate, Command) <- (do_one x);
  rest :: [](Command) <- (do_several (pred n) new_state);
  (return ((:) did_move rest));
})
});
good_end_state :: [](Command) -> Bool;
good_end_state c = ((==) (Just empty_hand) (run_through c));
state_tuples :: [](Command) -> [](Maybe(Hstate));
state_tuples c = (init(tail((scanl (flip execute_out_monad) (Just empty_hand) c))));
no_beats :: Filter;
no_beats = (and . (map ((/=) Beat)));
and_preds :: forall a . []((a -> Bool)) -> a -> Bool;
and_preds fs x = (and (do{
  f :: (a -> Bool) <- fs;
  (return (f x));
}));
in_state :: (Hstate -> Bool) -> [](Command) -> Bool;
in_state p c = (and((map (p . fromJust))(state_tuples(c))));
type Filter  = ([](Command) -> Bool);
always_down_1 :: Filter;
always_down_1 = (in_state ((/=) empty_hand));
always_down :: [](Command) -> Bool;
always_down c = ((&&) ((/=) c [Beat]) (always_down_1 c));
one_finger :: Hstate -> Bool;
one_finger (Hstate _ fingers) = (and (map (one_finger_per_hand fingers) (range h_bounds)));
one_finger_per_hand :: Fstate -> Hand -> Bool;
one_finger_per_hand finger target = (case (do{
  ((hand, _), Down) :: (Hand_finger, Direction) <- (assocs finger);
  (guard ((==) hand target));
  (return ());
}) of {
  ([] )-> True;
  ((:) (_ ) ([] ))-> True;
  _ -> False
});
data Thumb_command  = Thumb_beat | Thumb_specific(Tposition)(Direction) deriving (Show);
data Thumb_state  = Thumb_down | Thumb_up(Maybe(Tposition)) deriving (Show);
filter_thumb :: Hand -> Command -> [](Thumb_command);
filter_thumb target c = (case c of {
  Beat-> (return Thumb_beat);
  (Key hand (Thumb i) dir)
| ((==) hand target)
 -> (return (Thumb_specific i dir))
 ;
  _ -> []
});
move_thumb :: (Monad (m)) => m(Thumb_state) -> Thumb_command -> m(Thumb_state);
move_thumb oldm next = (do{
  old :: Thumb_state <- oldm;
  (case (old, next) of {
  (Thumb_down, Thumb_beat)-> (return Thumb_down);
  (Thumb_down, (Thumb_specific i Up))-> (return(Thumb_up(Just(i))));
  (Thumb_down, (Thumb_specific _ Down))-> (error "more down on down");
  ((Thumb_up Nothing), Thumb_beat)-> (return (Thumb_up Nothing));
  ((Thumb_up Nothing), (Thumb_specific _ Down))-> (return Thumb_down);
  ((Thumb_up (Just _)), Thumb_beat)-> (return (Thumb_up Nothing));
  ((Thumb_up _), (Thumb_specific _ Up))-> (error "more up on up");
  ((Thumb_up (Just i)), (Thumb_specific j Down))-> (case ((==) i j) of {
  True-> (return Thumb_down);
  _ -> (fail "moving thumb too fast")
})
});
});
test_thumb_minor :: [](Thumb_command) -> Maybe(Thumb_state);
test_thumb_minor c = (foldl move_thumb (Just (Thumb_up Nothing)) c);
from_empty :: Int -> []([](Command));
from_empty n = (do_several n empty_hand);
test_thumb_one_hand :: [](Command) -> Hand -> Maybe(Thumb_state);
test_thumb_one_hand c h = (test_thumb_minor(concat((map (filter_thumb h))(c))));
test_thumb :: [](Command) -> Bool;
test_thumb c = (and (map (isJust . (test_thumb_one_hand c)) (range h_bounds)));
show_chords :: Int -> IO(());
show_chords num_actions = (print(length((filter (and_preds [always_down, test_thumb, one_beat_at_a_time, good_end_state]))(from_empty(num_actions)))));
head_one_beat_at_a_time :: [](Command) -> Bool;
head_one_beat_at_a_time c = ((/=) [Beat, Beat] (take 2 c));
one_beat_at_a_time :: [](Command) -> Bool;
one_beat_at_a_time c = (and((map head_one_beat_at_a_time)(tails(c))))
}