{-# LANGUAGE OverloadedStrings, LambdaCase, RecordWildCards #-}
import Control.Monad
import Control.Concurrent
import Control.Exception (finally)
import Data.Aeson
import Foreign
import Codec.Picture as Juicy
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (unpack)
import qualified Data.Vector as V
import qualified Data.Vector.Storable as SV
import qualified Network.WebSockets as WS
import qualified Data.Map as Map
import Text.Printf
import System.FilePath
import System.Directory
import System.Process
import TestData
import LambdaCube.Linear
import LambdaCube.IR
import LambdaCube.PipelineSchema
import LambdaCube.PipelineSchemaUtil
import LambdaCube.Mesh
import qualified EditorExamplesTest
main :: IO ()
main = do
putStrLn "listening"
WS.runServer "192.168.0.12" 9160 application
application pending = do
conn <- WS.acceptRequest pending
WS.forkPingThread conn 30
let disconnect = return ()
one = 1 :: Int
flip finally disconnect $ do
-- receive client info
decodeStrict <$> WS.receiveData conn >>= \case
Nothing -> fail "invalid client info"
Just ci@ClientInfo{..} -> print ci
-- send pipeline
(testName,renderJob@RenderJob{..}) <- EditorExamplesTest.getRenderJob -- TODO
WS.sendTextData conn . encode $ renderJob
-- get render result: pipeline x scene x frame
res <- forM pipelines $ \PipelineInfo{..} -> do
forM (zip [one..] $ V.toList scenes) $ \(sIdx,Scene{..}) ->
forM [one..length frames] $ \fIdx -> do
let name = "backend-test-data/" ++ testName ++ "/result/" ++ takeBaseName pipelineName ++ "_scn" ++ printf "%02d" sIdx ++ "_" ++ printf "%02d" fIdx ++ ".png"
decodeStrict <$> WS.receiveData conn >>= \case
Nothing -> fail $ name ++ " - invalid RenderJobResult"
Just (RenderJobError e) -> fail $ name ++ " - render error:\n" ++ e -- TODO: test failed
Just (RenderJobResult FrameResult{..}) -> do
createDirectoryIfMissing True (takeDirectory name)
compareOrSaveImage name =<< toImage frImageWidth frImageHeight . either error id . B64.decode =<< WS.receiveData conn
--putStrLn $ name ++ "\t" ++ unwords (map showTime . V.toList $ frRenderTimes)
let differ = or $ concat $ fmap concat res
putStrLn $ "render job: " ++ if differ then "FAIL" else "OK"
forever $ threadDelay 1000000
compareOrSaveImage name img@(Image w h pixels) = do
doesFileExist name >>= \case
False -> do
putStrLn $ "new image: " ++ name
savePngImage name (ImageRGBA8 img)
return False
True -> do
Right (ImageRGBA8 (Image origW origH origPixels)) <- readImage name
let diffPixels a b = SV.sum $ SV.zipWith (\x y -> (fromIntegral x - fromIntegral y)^2) a b :: Float
diff = diffPixels pixels origPixels
threshold = 0
differ = w /= origW || h /= origH || diff > threshold
case differ of
True -> do
putStrLn $ name ++ " - differ!!! " ++ show diff
let mismatchImage = dropExtension name ++ "_mismatch.png"
diffImage = dropExtension name ++ "_diff.png"
putStrLn $ "save difference: " ++ diffImage
savePngImage mismatchImage (ImageRGBA8 img)
(exitCode,out,err) <- readProcessWithExitCode "compare" ["-compose","src",name,mismatchImage,diffImage] ""
--let res = read . head . words $ out :: Float
print (out,err)
False -> putStrLn $ name ++ " OK"
return differ
toImage :: Int -> Int -> BS.ByteString -> IO (Image PixelRGBA8)
toImage w h buf = do
fp <- mallocForeignPtrBytes (4*w*h)
withForeignPtr fp $ \dst -> BS.useAsCStringLen buf $ \(src,i) -> copyBytes dst (castPtr src) i
return $ Image w h $ SV.unsafeFromForeignPtr fp 0 (w*h)
showTime delta
| t > 1e-1 = printf "%.3fs" t
| t > 1e-3 = printf "%.1fms" (t/1e-3)
| otherwise = printf "%.0fus" (t/1e-6)
where
t = realToFrac delta :: Double
{-
data sets:
hello
editor
-}
{-
features to test:
blending
depth test
culling
texturing
uniform texture
render texture
multi draw calls into the same framebuffer
-}
-- TODO
{-
how to pair pipelines with predefined data
basically: storage - pipelines
render job:
gpu data
scene <--> storage
frame
-}
{-
initial test cases:
- hello - done
- editor exercises
TODO
create storage
collect pipelines
- create render job list
-}