hcube-0.1.0: HCube/Cube.hs

-----------------------------------------------------------------------------
-- | 
-- Module      :  HCube.Cube
-- Copyright   :  (c) Todd Wegner 2013
-- License     :  BSD-style (see the LICENSE file)
-- 
-- Maintainer  :  todd.w.wegner@gmail.com
-- Stability   :  provisional
-- Portability :  portable
-- 
-- Executable of hcube. 
-----------------------------------------------------------------------------
module Main where

import System.Environment (getArgs)
import Control.Monad (foldM, (>=>))
import Data.Maybe (fromMaybe)
import HCube.Data
import HCube.Lib
import HCube.Utility
import HCube.Cons
import HCube.Test (runTests)
import HCube.Theory
import HCube.Template (render)
import HCube.OrientGroup
import HCube.Permutation

{-
ghci Cube.hs
:set args 2
-}

main			:: IO ()
main			= getArgs >>= f where
    f args		= runTests
			  >> putStrLn "enter 'help' for menu"
			  >> loadCube g h
			  >>= render
			  >>= console
			  >>= saveCube h
			  >> return () where
        g		= getCubeSize args
	h		= show g ++ "x" ++ show g

main2			:: IO ()
main2			= getArgs >>= f where
    f args		= runTests
			  >> putStrLn "enter 'help' for menu"
			  >> return ( realToVirtual 3 myCube)
			  >>= render
			  >>= console
			  >> return () where
        g		= getCubeSize args
	h		= show g ++ "x" ++ show g

getCubeSize		:: [String] -> Int 
getCubeSize 		= f where
    f []		= 3
    f args		= fromMaybe 3 $ maybeRead $ head args 

console			:: Rubik -> IO Rubik
console			= doM loop f where
   f			= (getLine >>= parseCmd ~> processCmd) >=> render 

processCmd		:: Command -> Rubik -> IO Rubik
processCmd cm rk	= f cm where
    f (Projection pj)   = return $ rk { view = pj }
    f Quit		= return $ rk { loop = False }
    f (Operation ops)	= appendHis ops rk >>= return . doCubeOps ops
    f Undo		= undo rk
    f Help		= putStrLn help >> return rk
    f NoCommand		= return rk

appendHis		:: [Rotation] -> Rubik -> IO Rubik
appendHis ops rk	= return $ rk { his = ops ++ (his rk) }

removeLastHis		:: Rubik -> IO Rubik
removeLastHis rk	= return $ rk { his = tail (his rk) }

undo			:: Rubik -> IO Rubik
undo rk			= f (his rk) where
    f []		= return rk
    f hs		= return ( doCubeOps [invOpp $ head hs] rk )
			>>= removeLastHis

help			= unlines 
       ["l1+    rotate layer 1 clockwise",
	"l2-    rotate layer 2 counter",
	"h3+    rotate horizontal slab 3 clockwise",
	"h1-    rotate horizontal slab 1 counter",
	"v2+    rotate vertical slab 2 clockwise",
	"v3-    rotate vertical slab 3 counter",
	"l      left side view",
	"r      right side view",
	"r+     rotate whole cube clockwise 90 degrees (z axis)",
	"r-     rotate whole cube counter clockwise 90 degrees (z axis)",
	"r2     rotate whole cube 180 degrees",
	"fh     flip whole cube over along horizontal axis",
	"fv     flip whole cube over along vertical axis",
	"u      undo last cube operation",
	"q      quit"]

parseCmd		:: String -> IO Command
parseCmd 		= return . f where
    f "l"		= Projection LeftV
    f "r"		= Projection RightV
    f "q"		= Quit
    f "r+"		= Operation [RotateCube Layer Clockwise]
    f "r-"		= Operation [RotateCube Layer Counter]
    f "r2"		= Operation [RotateCube Layer Twice]
    f "fh"		= Operation [RotateCube HSlice Twice]
    f "fv"		= Operation [RotateCube VSlice Twice]
    f "help"		= Help
    f (a:b:c:[])	= verifyOp (g a) (h c) (i b)
    f "u"		= Undo
    f _			= NoCommand
    g 'l'		= Layer
    g 'h'		= HSlice
    g 'v'		= VSlice
    g _			= NoSlab
    h '+'		= Clockwise
    h '-'		= Counter
    h '2'		= Twice
    h _			= NoDir
    i ch		= fromMaybe 0 $ maybeRead [ch]

verifyOp		:: Slab -> Direction -> Numb -> Command 
verifyOp 		= f where
    f NoSlab _ _	= NoCommand
    f _ NoDir _		= NoCommand
    f _ _ 0		= NoCommand
    f sl dr nm		= Operation [Rotation sl dr nm]

-- On a face record cube color from left to right moving from top to bottom.
-- Start with Top face
-- Rotate cube so Front face comes to Top
-- Top -> Front -> Bottom -> Back -> Top -> Left -> Top -> Right

{-
FACE IDs
               1  2  
               3  4  
         1  2  1  2  1  2  
         3  4  3  4  3  4  
               1  2  
               3  4  
         4  3  1  2  4  3  
         2  1  3  4  2  1  
               1  2  
               3  4   
-}

myCube	:: CubeSurf
myCube = [(UpS,	[White,Green,Yellow,Green,White,Green,Red,White,Green]),
	  (FrontS, 	[Blue,Blue,White,Yellow,Orange,Yellow,Red,Yellow,White]),
	  (DownS,	[Yellow,Blue,Green,White,Yellow,Blue,White,Orange,Green]),
	  (BackS,	[Orange,Blue,Orange,Yellow,Red,Red,Red,Orange,Blue]),
	  (LeftS,	[Orange,White,Yellow,Red,Green,Red,Orange,Red,Red]),
	  (RightS,	[Blue,Green,Blue,Orange,Blue,White,Green,Orange,Yellow])]