hsqml-demo-manic (empty) → 0.3.4.0
raw patch · 15 files changed
+1159/−0 lines, 15 filesdep +MonadRandomdep +basedep +containerssetup-changed
Dependencies added: MonadRandom, base, containers, hsqml, text
Files
- CHANGELOG +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- hsqml-demo-manic.cabal +37/−0
- qml/BasicTileTest.qml +38/−0
- qml/Board.qml +222/−0
- qml/Leak.qml +55/−0
- qml/Main.qml +133/−0
- qml/Plumb.qml +168/−0
- qml/corner_mask.svg +5/−0
- qml/end_mask.svg +6/−0
- qml/full_mask.svg +6/−0
- qml/mouse.svg +6/−0
- qml/straight_mask.svg +6/−0
- src/Main.hs +440/−0
+ CHANGELOG view
@@ -0,0 +1,5 @@+HsQML Manic - Release History++release-0.3.4.0 - 2016.10.16++ * Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014-2016, Robin KAY++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Robin KAY nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hsqml-demo-manic.cabal view
@@ -0,0 +1,37 @@+Name: hsqml-demo-manic+Version: 0.3.4.0+Cabal-version: >=1.10+Build-type: Simple+License: BSD3+License-file: LICENSE+Copyright: (c) 2014-2016 Robin KAY+Author: Robin KAY+Maintainer: komadori@gekkou.co.uk+Homepage: http://www.gekkou.co.uk/software/hsqml/+Category: Game+Synopsis: HsQML-based clone of Pipe Mania+Data-dir: qml+Data-files: *.qml *.svg+Extra-source-files: CHANGELOG+Description:+ HsQML-based clone of Pipe Mania++executable hsqml-manic+ Default-language: Haskell2010+ Hs-source-dirs: src+ Main-is: Main.hs+ Other-extensions:+ ScopedTypeVariables,+ DeriveDataTypeable,+ TypeFamilies+ Build-depends:+ base == 4.*,+ containers >= 0.4 && < 0.6,+ text >= 0.11 && < 1.3,+ MonadRandom >= 0.4 && < 0.5,+ hsqml >= 0.3.4 && < 0.4+ GHC-options: -threaded++Source-repository head+ type: darcs+ location: http://hub.darcs.net/komadori/hsqml-demo-manic
+ qml/BasicTileTest.qml view
@@ -0,0 +1,38 @@+import QtQuick 2.0++Grid {+ columns: 5;+ columnSpacing: 5;+ rowSpacing: 5;++ property var colours: ['lime','yellow','darkgoldenrod','blue'];+ property int colIndex: 0;++ property double vol: 0;+ SequentialAnimation on vol {+ NumberAnimation {+ from: 0; to: 0; duration: 1000;+ }+ NumberAnimation {+ from: 0; to: 1.1; duration: 5000;+ }+ NumberAnimation {+ from: 1.1; to: 1.1; duration: 1000;+ }+ ScriptAction {+ script: colIndex = (colIndex+1)%colours.length;+ }+ loops: Animation.Infinite;+ }++ Repeater {+ model: 25;++ Plumb {+ entryA: Math.floor(index / 5) * 90;+ exitA: (index % 5) * 90;+ colour: colours[colIndex];+ volume: vol;+ }+ }+}
+ qml/Board.qml view
@@ -0,0 +1,222 @@+import QtQuick 2.0+import QtGraphicalEffects 1.0+import HsQML.Model 1.0++Item {+ id: c;+ property int tilesWide : 8;+ property int tilesHigh : 8;+ property bool isVirtual : false;+ property color bgColor : 'cornsilk';++ property double tileSize : Math.floor(Math.min(+ width / tilesWide, height / tilesHigh));+ property var tileSource : newTileSource();+ property var gridModel : newGrid();+ property var plumbedGrid : gridModel.plumb();++ signal pressedComplete();++ property double countDown;+ NumberAnimation on countDown {+ id: countAnim;+ from: 3; to: 0;+ duration: 9000;+ running: false;+ onStopped: volumeAnim.start(); + }++ property double n : 0;+ NumberAnimation on n {+ id: volumeAnim;+ from: 0; to: 100 + 0.1;+ duration: 5000 * (100 + 0.1);+ running: false;+ }++ property bool gameOver :+ (!countAnim.running && !volumeAnim.running) ||+ n > (plumbedGrid.maxIndex+1) ||+ plumbedGrid.leaks.length == 0;++ function start() {+ tileSource = newTileSource();+ gridModel = newGrid();+ if (c.isVirtual) {+ virtualMouse.pick();+ }+ countAnim.restart();+ volumeAnim.stop();+ n = 0;+ }++ Rectangle {+ width: c.tileSize*c.tilesWide;+ height: c.tileSize*c.tilesHigh;+ color: c.bgColor;+ MouseArea {+ id: realMouse;+ anchors.fill: parent;+ hoverEnabled: true;+ }+ }++ Repeater {+ anchors.fill: parent;+ model: AutoListModel {+ mode: AutoListModel.ByKey;+ source: {+ var rs = plumbedGrid.leaks;+ rs.sort(function(a,b) {return a.idx-b.idx;});+ return rs;+ }+ equalityTest: function(a,b) {+ a.idx==b.idx && a.colour==b.colour && a.exitA==b.exitA;}+ keyFunction: function(a) {return a.x+'-'+a.y;}+ }++ Leak {+ tileSize: c.tileSize;+ tileX: modelData.x;+ tileY: modelData.y;+ colour: modelData.colour;+ exitBearing: modelData.exitA;+ trigger: n >= modelData.idx;+ }+ }++ Repeater {+ id: tiles;+ model: AutoListModel {+ source: plumbedGrid.plumbing;+ mode: AutoListModel.ByKey;+ equalityTest: function(a,b) {+ return a.idx==b.idx && a.entryA==b.entryA && a.exitA==b.exitA;}+ keyFunction: function(a) {return a.x+"-"+a.y;}+ }++ Plumb {+ tileSize: c.tileSize;+ x: modelData.x*c.tileSize;+ y: modelData.y*c.tileSize;+ entryA: modelData.entryA;+ exitA: modelData.exitA;+ colour: modelData.colour;+ label: modelData.colour;+ volume: modelData.idx < 0 ?+ 0 : Math.min(Math.max(c.n-modelData.idx,0),1.1);+ }+ }++ Text {+ visible: c.countDown > 0;+ anchors.centerIn: parent;+ text: Math.floor(c.countDown+1);+ font.pixelSize: c.tileSize*2;+ scale: 1+Math.ceil(c.countDown)-c.countDown;+ opacity: 0.5-(Math.ceil(c.countDown)-c.countDown)/2;+ }++ Rectangle {+ id: mouseView;+ property var mouse: c.gameOver ? noMouse :+ (c.isVirtual ? virtualMouse : realMouse);+ property int tileX: Math.floor(mouse.mouseX/c.tileSize);+ property int tileY: Math.floor(mouse.mouseY/c.tileSize);+ property bool tilePlacable:+ plumbedGrid.isPlacable(Math.floor(c.n), tileX, tileY);++ Connections {+ target: mouseView.mouse;+ onPressed: {+ if (mouseView.tilePlacable) {+ c.gridModel = c.gridModel.place(+ mouseView.tileX, mouseView.tileY, tileSource.top.tile);+ c.tileSource = c.tileSource.next;+ }+ c.pressedComplete();+ } + }++ visible: mouseView.mouse.containsMouse;+ x: tileX*c.tileSize;+ y: tileY*c.tileSize;+ width: c.tileSize; height: c.tileSize;+ color: 'lightgray'; opacity: 0.5;+ Text {+ visible: !mouseView.tilePlacable;+ anchors.centerIn: parent;+ color: 'red';+ font.pixelSize: c.tileSize;+ text: 'X';+ }+ }++ Item {+ id: virtualMouse;+ property bool done : false;+ property bool active : true;+ property double oldTileX : 0;+ property double oldTileY : 0;+ property double tileX : 0;+ property double tileY : 0;+ property double dur : 0;+ Behavior on tileX {+ NumberAnimation {+ id: animX;+ duration: virtualMouse.dur;+ }+ }+ Behavior on tileY {+ NumberAnimation {+ id: animY;+ duration: virtualMouse.dur;+ }+ }+ NumberAnimation {+ id: xyAnim;+ duration: virtualMouse.dur;+ onStopped: virtualMouse.pressed();+ }+ function pick() {+ if (done) return;+ gridModel.pick(c.tileSource, tileX, tileY, Math.floor(c.n));+ }+ focus: true;+ Keys.enabled: true;+ Keys.onSpacePressed: done = true;+ function move(pos) {+ dur = 300*Math.max(1,Math.sqrt(+ (tileX-pos.x)*(tileX-pos.x)+(tileY-pos.y)*(tileY-pos.y)));+ tileX = pos.x;+ tileY = pos.y;+ xyAnim.start();+ }+ Connections {+ target: c;+ onPressedComplete: virtualMouse.pick();+ }+ Connections {+ target: c.gridModel;+ onPicked: virtualMouse.move(pos); + }+ property int mouseX : (tileX+0.5)*c.tileSize;+ property int mouseY : (tileY+0.5)*c.tileSize;+ property bool containsMouse : true;+ signal pressed();++ Image {+ visible: mouseView.mouse == virtualMouse; + x: virtualMouse.mouseX; y: virtualMouse.mouseY;+ source: 'mouse.svg'+ }+ }++ Item {+ id: noMouse;+ property int mouseX : 0;+ property int mouseY : 0;+ property bool containsMouse : false;+ signal pressed();+ }+}
+ qml/Leak.qml view
@@ -0,0 +1,55 @@+import QtQuick 2.0+import QtGraphicalEffects 1.0++Item {+ id: c;+ anchors.fill: parent;++ property double tileX : 0;+ property double tileY : 0;+ property double tileSize : 100;+ property int exitBearing : 0;+ property color colour : 'green';+ property bool trigger : false;++ onTriggerChanged:+ if (trigger) {sizeAnim.start();} else {sizeAnim.stop(); grad.size = 0;}++ RadialGradient {+ id: grad;+ anchors.fill: parent;+ property double cx: {+ var h=0;+ switch (c.exitBearing) {+ case 0: h=0.5; break; case 90: h=0.9; break;+ case 180: h=0.5; break; case 270: h=0.1; break;+ }+ return (c.tileX+h)*c.tileSize;+ }+ horizontalOffset: cx-c.width/2;+ property double cy: {+ var v=0;+ switch (c.exitBearing) {+ case 0: v=0.1; break; case 90: v=0.5; break;+ case 180: v=0.9; break; case 270: v=0.5; break;+ }+ return (c.tileY+v)*c.tileSize;+ }+ verticalOffset: cy-c.height/2;+ horizontalRadius: size*1.5*c.tileSize;+ verticalRadius: size*1.5*tileSize;+ gradient: Gradient {+ GradientStop { position: 0.9; color: c.colour; }+ GradientStop { position: 1.0; color: Qt.rgba(0,0,0,0); }+ }++ property double size : 0;+ NumberAnimation on size {+ id: sizeAnim;+ from: 0; to: 1;+ duration: 3000;+ easing.type: Easing.OutQuad;+ running: false;+ }+ }+}
+ qml/Main.qml view
@@ -0,0 +1,133 @@+import QtQuick 2.0+import QtQuick.Window 2.0+import QtQuick.Layouts 1.0+import HsQML.Model 1.0++Window {+ visible: true;+ width: 900; height: 800;++ RowLayout {+ anchors.fill: parent;++ Item {+ Layout.fillWidth: true;+ Layout.fillHeight: true;+ Board {+ id: board;+ anchors.fill: parent;+ onGameOverChanged: if (board.gameOver) {+ idleTimer.restart();+ idleTimer.count = 9;+ }+ }+ Timer {+ id: idleTimer;+ interval: 1000;+ repeat: true;+ property int count : 10;+ onTriggered: if (--idleTimer.count == 0) {+ board.isVirtual = true;+ board.start();+ }+ }+ Rectangle {+ width: 1.2*btnText.width;+ height: 1.2*btnText.height;+ anchors.centerIn: parent;+ color: 'green';+ radius: 0.1*btnText.height;+ property bool showButton : board.gameOver || board.isVirtual;+ enabled: showButton;+ opacity: showButton ? (btnArea.containsMouse ? 1 : 0.5) : 0;+ Behavior on opacity {+ NumberAnimation { duration: 500; }+ }+ MouseArea {+ id: btnArea;+ anchors.fill: parent;+ hoverEnabled: true;+ onClicked: {+ idleTimer.count = 0;+ board.isVirtual = false;+ board.start();+ }+ cursorShape: Qt.PointingHandCursor;+ }+ Text {+ id: btnText;+ anchors.centerIn: parent;+ color: 'white';+ font.pixelSize: 0.1*board.height;+ text: 'Play';+ }+ }+ Text {+ anchors.horizontalCenter: parent.horizontalCenter;+ anchors.top: top.bottom;+ anchors.topMargin: 5;+ visible: board.isVirtual;+ opacity: 0.5;+ font.pixelSize: 0.05*board.height;+ text: 'Demo Mode';+ }+ Text {+ anchors.horizontalCenter: parent.horizontalCenter;+ anchors.bottom: parent.bottom;+ anchors.bottomMargin: 5;+ visible: board.isVirtual;+ opacity: 0.5;+ font.pixelSize: 0.05*board.height;+ text: 'Demo Mode';+ }+ Text {+ anchors.bottom: parent.bottom;+ anchors.left: parent.left;+ anchors.bottomMargin: 5;+ anchors.leftMargin: 5;+ visible: idleTimer.count > 0;+ opacity: 0.5;+ font.pixelSize: 0.05*board.height;+ text: idleTimer.count;+ }+ }+ ListView {+ id: tileList;+ model: AutoListModel {+ mode: AutoListModel.ByKey;+ source: board.tileSource.topN(tileList.height/100);+ equalityTest: function(a, b) {return a.tile == b.tile;}+ keyFunction: function(x) {return x.idx;}+ }+ delegate: Item {+ width: 100; height: 100; + Repeater {+ anchors.fill: parent;+ model: sparePart(modelData.tile);+ Plumb {+ anchors.fill: parent;+ entryA: modelData.entryA;+ exitA: modelData.exitA;+ volume: 0;+ }+ }+ }+ displaced: Transition {+ NumberAnimation { properties: "x,y"; duration: 1000; }+ NumberAnimation { properties: "scale"; duration: 1000; to: 1; }+ }+ add: Transition {+ NumberAnimation {+ properties: "scale"; duration: 1000; from: 0; to: 1;+ }+ }+ remove: Transition {+ NumberAnimation {+ properties: "scale"; duration: 1000; to: 0;+ }+ }+ Layout.fillHeight: true;+ width: 100;+ }+ }+}
+ qml/Plumb.qml view
@@ -0,0 +1,168 @@+import QtQuick 2.0+import QtGraphicalEffects 1.0++Item {+ id: c;+ width: tileSize;+ height: tileSize;++ property double tileSize : 100;+ property double internalTileSize : 100;++ property var entryA : null;+ property var exitA : null;+ property double volume : 0;+ property color colour : 'green';+ property string label : '';++ property string _maskSource : '';+ property int _maskRotation : 0;+ property string _maskLetter : '';++ function setup() {+ var source = '', rotation = 0, letter = '';+ if (rotate(c.entryA, 180) == c.exitA) {+ source = 'straight';+ rotation = c.entryA;+ }+ else if (rotate(c.entryA, 90) == c.exitA) {+ source = 'corner';+ rotation = c.entryA;+ }+ else if (rotate(c.exitA, 90) == c.entryA) {+ source = 'corner';+ rotation = c.exitA;+ }+ else if (isOrtho(c.entryA) && !isOrtho(c.exitA)) {+ source = 'end';+ rotation = c.entryA;+ letter = 'E';+ }+ else if (isOrtho(c.exitA) && !isOrtho(c.entryA)) {+ source = 'end';+ rotation = c.exitA;+ letter = 'S';+ }+ else {+ source = 'full';+ letter = 'X';+ }+ c._maskSource = source;+ c._maskRotation = rotation;+ c._maskLetter = letter;+ }+ Component.onCompleted: setup();+ onEntryAChanged: setup();+ onExitAChanged: setup();++ function rotate(a, d) {+ return isOrtho(a) ? (a+d)%360 : -1;+ }++ function isOrtho(a) {+ return a == 0 || a == 90 || a == 180 || a == 270;+ }++ DropShadow {+ anchors.fill: c;+ radius: 0.025*c.tileSize;+ spread: 0.8;+ fast: true;+ color: 'black';+ opacity: 0.2;+ source: uncached_mask;+ layer.enabled: true;+ clip: true;+ }+ LinearGradient {+ function steer(n, dir) {+ switch (dir) {+ case 0: return {x: 0.5, y: n};+ case 90: return {x: 1-n, y: 0.5};+ case 180: return {x: 0.5, y: 1-n};+ case 270: return {x: n, y: 0.5};+ }+ return {x: 0.5, y: 0.5};+ }++ function point(p) {+ return Qt.point(p.x*c.width, p.y*c.height);+ }++ function calc(vol, t, ena, exa) {+ var band = 0.3;+ var t2 = t + band;+ if (!isOrtho(ena)) {+ vol = 0.4+vol*0.6;+ ena = rotate(exa, 180);+ }+ else if (!isOrtho(exa)) {+ vol = vol*0.6;+ exa = rotate(ena, 180);+ }+ exa = rotate(exa, 180);+ if (vol < t) {+ return point(steer(vol, ena));+ }+ else if (vol < t2) {+ var v = (vol-t)/band;+ var a = steer(t, ena);+ var b = steer(t2, exa);+ return point({x: a.x*(1-v)+b.x*v, y: a.y*(1-v)+b.y*v});+ }+ else {+ return point(steer(vol, exa));+ }+ }++ id: grad;+ anchors.fill: parent;+ start: calc(c.volume-0.1, 0.3, c.entryA, c.exitA);+ end: calc(c.volume, 0.4, c.entryA, c.exitA);+ gradient: Gradient {+ GradientStop { position: 0.0; color: colour; }+ GradientStop { position: 1.0; color: Qt.rgba(0,0,0,0.1); }+ }+ source: mask; + }+ Item {+ id: mask;+ anchors.fill: parent; visible: false;+ layer.enabled: true;+ Item {+ id: uncached_mask;+ anchors.fill: parent;+ Image {+ anchors.fill: parent;+ rotation: c._maskRotation;+ source: c._maskSource + '_mask.svg';+ sourceSize.width: c.internalTileSize;+ sourceSize.height: c.internalTileSize;+ }+ }+ }+ Item {+ anchors.fill: parent;+ visible: c._maskLetter != '';+ Text {+ anchors.centerIn: parent;+ font.pixelSize: 0.2*c.tileSize;+ text: c._maskLetter;+ color: c.colour.r + c.colour.g + c.colour.b > 1.5 ?+ Qt.darker(c.colour, 2) : Qt.lighter(c.colour, 2);+ }+ Item {+ anchors.fill: parent;+ rotation: rotate(c._maskRotation, 270) % 180;+ Text {+ x: rotate(c._maskRotation,90) <= 90 ? 0 : 0.4*c.tileSize;+ y: 0.25*c.tileSize;+ width: 0.6*c.tileSize;+ horizontalAlignment: rotate(c._maskRotation,90) <= 90 ?+ Text.AlignRight : Text.AlignLeft;+ font.pixelSize: 0.1*c.tileSize;+ text: c.label;+ }+ }+ }+}
+ qml/corner_mask.svg view
@@ -0,0 +1,5 @@+<?xml version="1.0" ?>+<svg version="1.1" baseProfile="full" xmlns="http://www.w3.org/2000/svg"+ viewBox="0 0 100 100">+ <path d="M40,0 L60,0 L60,35 S60,40,65,40 L100,40 L100,60 L45,60 S40,60,40,55 Z" fill="black" />+</svg>
+ qml/end_mask.svg view
@@ -0,0 +1,6 @@+<?xml version="1.0" ?>+<svg version="1.1" baseProfile="full" xmlns="http://www.w3.org/2000/svg"+ viewBox="0 0 100 100">+ <path d="M40,0 L60,0 L60,60 L40,60 Z" fill="black" />+</svg>+
+ qml/full_mask.svg view
@@ -0,0 +1,6 @@+<?xml version="1.0" ?>+<svg version="1.1" baseProfile="full" xmlns="http://www.w3.org/2000/svg"+ viewBox="0 0 100 100">+ <path d="M40,40 L60,40 L60,60 L40,60 Z" fill="black" />+</svg>+
+ qml/mouse.svg view
@@ -0,0 +1,6 @@+<?xml version="1.0" ?>+<svg version="1.1" baseProfile="full" xmlns="http://www.w3.org/2000/svg"+ viewBox="0 0 100 100">+ <path d="M0,0 L30,0 L20,10 L60,50 L50,60 L10,20 L0,30 Z" fill="red" stroke="black" stroke-width="1" />+</svg>+
+ qml/straight_mask.svg view
@@ -0,0 +1,6 @@+<?xml version="1.0" ?>+<svg version="1.1" baseProfile="full" xmlns="http://www.w3.org/2000/svg"+ viewBox="0 0 100 100">+ <path d="M40,0 L60,0 L60,100 L40,100 Z" fill="black" />+</svg>+
+ src/Main.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, TypeFamilies #-}+module Main where++import Control.Concurrent (forkIO)+import Control.Exception (evaluate)+import Control.Applicative ((<$>))+import Control.Monad+import Control.Monad.Random+import Data.Function+import Data.Typeable+import Data.Text (Text)+import qualified Data.Text as T+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.List+import Graphics.QML+import Graphics.QML.Objects.ParamNames++import Paths_hsqml_demo_manic++data Bearing = North | East | South | West+ deriving (Typeable, Eq, Enum, Bounded, Show, Read)++instance Marshal Bearing where+ type MarshalMode Bearing c d = ModeTo c+ marshaller = toMarshaller (\x -> case x of+ North -> 0 :: Int+ East -> 90+ South -> 180+ West -> 270)++data Orientation =+ Horizontal | Vertical deriving (Eq, Enum, Bounded, Show, Read)++data Colour = Green | Yellow | Brown | Blue+ deriving (Typeable, Eq, Enum, Bounded, Show, Read)++instance Marshal Colour where+ type MarshalMode Colour c d = ModeTo c+ marshaller = toMarshaller (\x -> case x of+ Green -> T.pack "lime" :: Text+ Yellow -> T.pack "yellow"+ Brown -> T.pack "darkgoldenrod"+ Blue -> T.pack "blue")++data Tile+ = Start Colour Bearing+ | End Colour Bearing+ | Corner Bearing+ | Straight Orientation+ | Cross+ deriving (Eq, Show, Read)++data NumberedTile = NumberedTile Tile Int deriving Typeable++newtype TileSource = TileSource [NumberedTile] deriving Typeable++instance Marshal NumberedTile where+ type MarshalMode NumberedTile c d = ModeObjBidi NumberedTile c+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC++instance DefaultClass NumberedTile where+ classMembers = [+ defPropertyConst "tile" (\(NumberedTile tile _) -> return tile),+ defPropertyConst "idx" (\(NumberedTile _ idx) -> return idx)]++instance Marshal TileSource where+ type MarshalMode TileSource c d = ModeObjBidi TileSource c+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC++instance DefaultClass TileSource where+ classMembers = [+ defPropertyConst "top" (\(TileSource ts) -> return $ head ts),+ defPropertyConst "next" (\(TileSource ts) ->+ return $ TileSource $ tail ts),+ defMethod "topN" (\(TileSource ts) n ->+ return $ take n ts :: IO [NumberedTile])]++newTileSource :: IO TileSource+newTileSource = do+ g <- newStdGen+ return $ TileSource $ zipWith NumberedTile (randomTiles g) [0..]++randomEnum :: forall g e. (RandomGen g, Enum e, Bounded e) => Rand g e+randomEnum = toEnum <$> getRandomR (fromEnum lo, fromEnum hi)+ where lo = minBound :: e+ hi = maxBound :: e++randomTile :: (RandomGen g) => Rand g Tile+randomTile = join $ fromList [+ (fmap Corner randomEnum, 4),+ (fmap Straight randomEnum, 2),+ (return Cross, 1)]++randomTiles :: (RandomGen g) => g -> [Tile]+randomTiles = unfoldr (Just . runRand randomTile)++instance Marshal Tile where+ type MarshalMode Tile c d = ModeBidi c+ marshaller = bidiMarshaller (read . T.unpack) (T.pack . show)++data Point = Pt !Int !Int deriving (Typeable, Eq, Ord, Show)++instance DefaultClass Point where+ classMembers = [+ defPropertyConst "x" (\(Pt x _) -> return x),+ defPropertyConst "y" (\(Pt _ y) -> return y)]++instance Marshal Point where+ type MarshalMode Point c d = ModeObjBidi Point c+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC ++data Grid = Grid Int Int (Map Point Tile) deriving (Typeable, Show)++place :: Point -> Tile -> Grid -> Grid+place pt tile (Grid w h grid) = Grid w h $ Map.insert pt tile grid++placeIfFree :: Point -> Tile -> Grid -> Grid+placeIfFree pt tile (Grid w h grid) = Grid w h $ Map.alter (\oldTile ->+ if isJust oldTile then oldTile else Just tile) pt grid++data PickedSignal deriving Typeable++instance SignalKeyClass PickedSignal where+ type SignalParams PickedSignal = Point -> IO ()++instance DefaultClass Grid where+ classMembers = [+ defPropertyConst "width" (\(Grid w _ _) -> return w),+ defPropertyConst "height" (\(Grid _ h _) -> return h),+ defMethod "place" (\grid x y tile ->+ return $ place (Pt x y) tile grid :: IO Grid),+ defMethod "plumb" (return . plumbGrid :: Grid -> IO PlumbedGrid),+ defMethod "pick" (\grid tiles currX currY vol -> void $ forkIO $ do+ let (Pt x y) = pickMove (fromObjRef grid) tiles (Pt currX currY) vol+ x' <- evaluate x+ y' <- evaluate y+ let pos = Pt x' y'+ fireSignal (Proxy :: Proxy PickedSignal) grid pos),+ defSignalNamedParams "picked" (Proxy :: Proxy PickedSignal) $+ fstName "pos"]++instance Marshal Grid where+ type MarshalMode Grid c d = ModeObjBidi Grid c+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC ++data PlumbedGrid = PlumbedGrid [Plumb] [Leak] (Map Point Int)+ deriving Typeable++isPlacable :: PlumbedGrid -> Int -> Point -> Bool+isPlacable (PlumbedGrid _ _ indexMap) n pt =+ maybe True (> n) $ Map.lookup pt indexMap++instance DefaultClass PlumbedGrid where+ classMembers = [+ defPropertyConst "plumbing" (\(PlumbedGrid ps _ _) -> return ps),+ defPropertyConst "leaks" (\(PlumbedGrid _ ls _) -> return ls),+ defPropertyConst "maxIndex" (\(PlumbedGrid ps _ _) ->+ return . minimum . filter (>= 0) .+ map (maximum . map (\(Plumb _ i _ _ _) -> i)) $+ groupBy ((==) `on` (\(Plumb c _ _ _ _) -> c)) ps),+ defMethod "isPlacable" (\pGrid n x y ->+ return $ isPlacable pGrid n (Pt x y) :: IO Bool)]++instance Marshal PlumbedGrid where+ type MarshalMode PlumbedGrid c d = ModeObjBidi PlumbedGrid c+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC ++data Plumb = Plumb Colour Int Point (Maybe Bearing) (Maybe Bearing)+ deriving (Typeable, Show)++instance DefaultClass Plumb where+ classMembers = [+ defPropertyConst "colour" (\(Plumb col _ _ _ _) -> return col),+ defPropertyConst "idx" (\(Plumb _ idx _ _ _) -> return idx),+ defPropertyConst "x" (\(Plumb _ _ (Pt x _) _ _) -> return x),+ defPropertyConst "y" (\(Plumb _ _ (Pt _ y) _ _) -> return y),+ defPropertyConst "entryA" (\(Plumb _ _ _ theta _) -> return theta),+ defPropertyConst "exitA" (\(Plumb _ _ _ _ theta) -> return theta)]++instance Marshal Plumb where + type MarshalMode Plumb c d = ModeObjBidi Plumb c+ marshaller = bidiMarshallerIO (return . fromObjRef) newObjectDC++newtype Leak = Leak {unLeak :: Plumb}++instance Marshal Leak where + type MarshalMode Leak c d = ModeObjBidi Plumb c+ marshaller = bidiMarshaller Leak unLeak++bend :: Bearing -> Bearing+bend North = East+bend East = South+bend South = West+bend West = North++invert :: Bearing -> Bearing+invert = bend . bend++revBend :: Bearing -> Bearing+revBend = bend . bend . bend++nextPos :: Maybe Bearing -> Point -> Point+nextPos (Just North) (Pt x y) = Pt x (y-1)+nextPos (Just East) (Pt x y) = Pt (x+1) y+nextPos (Just South) (Pt x y) = Pt x (y+1)+nextPos (Just West) (Pt x y) = Pt (x-1) y+nextPos Nothing p = p++plumbTile :: (Point -> Maybe Tile) -> PrePlumb -> Maybe Plumb+plumbTile getTile (PrePlumb col idx curr flow) = case getTile curr of+ Just (Start c theta)+ | flow == Nothing && col == c ->+ Just $ Plumb col idx curr Nothing (Just theta) + Just (End c theta)+ | flow == Just (invert theta) && col == c ->+ Just $ Plumb col idx curr (Just theta) Nothing+ Just (Straight Horizontal)+ | flow == Just East || flow == Just West ->+ Just $ Plumb col idx curr (fmap invert flow) flow+ Just (Straight Vertical)+ | flow == Just North || flow == Just South ->+ Just $ Plumb col idx curr (fmap invert flow) flow+ Just (Corner theta)+ | flow == Just (invert theta) ->+ Just $ Plumb col idx curr (Just theta) (Just $ bend theta)+ | flow == Just (revBend theta) ->+ Just $ Plumb col idx curr (Just $ bend theta) (Just theta)+ Just Cross -> Just $ Plumb col idx curr (fmap invert flow) flow+ _ -> Nothing++data Terminal = Success | EmptyTile | BadPipe deriving Show++data PrePlumb = PrePlumb Colour Int Point (Maybe Bearing) deriving Show++unPlumb :: Plumb -> PrePlumb+unPlumb (Plumb col idx curr inflow _) =+ PrePlumb col idx curr (fmap invert inflow)++plumbOn :: Plumb -> PrePlumb+plumbOn (Plumb col idx curr _ flow) =+ PrePlumb col (idx+1) (nextPos flow curr) flow++plumbStep ::+ (Point -> Maybe Tile) -> PrePlumb -> Either Terminal (Plumb, PrePlumb)+plumbStep tileFn pre@(PrePlumb _ _ curr flow) = case tileFn curr of+ Just _ -> case plumbTile tileFn pre of+ Just plumb -> Right (plumb, plumbOn plumb)+ Nothing -> maybe (Left Success) (const $ Left BadPipe) flow+ Nothing -> Left EmptyTile++unfoldrEither :: (b -> Either c (a, b)) -> b -> (c, [a])+unfoldrEither f b = case f b of+ Right (a,b') -> (a:) <$> unfoldrEither f b'+ Left c -> (c, [])++plumbStart :: Grid -> Colour -> Point -> Maybe Bearing -> (Terminal, [Plumb])+plumbStart (Grid _ _ grid) col start flow =+ unfoldrEither (plumbStep (`Map.lookup` grid)) $+ PrePlumb col 0 start flow++plumbAllStarts :: Grid -> [[Plumb]]+plumbAllStarts grid = foldStarts (\col curr ps ->+ snd (plumbStart grid col curr Nothing) : ps) [] grid++foldStarts :: (Colour -> Point -> a -> a) -> a -> Grid -> a+foldStarts f s (Grid _ _ gridMap) =+ Map.foldWithKey (\curr tile a -> case tile of+ Start col _ -> f col curr a+ _ -> a) s gridMap++plumbLeak :: [Plumb] -> Maybe Leak+plumbLeak ps =+ case last ps of+ Plumb col idx end _ (Just flow) ->+ Just $ Leak $ Plumb col (idx+1) end Nothing $ Just flow+ _ -> Nothing++stripPlumbed :: [Plumb] -> Grid -> Grid+stripPlumbed ps (Grid w h grid) =+ Grid w h $ foldl' (flip $ \(Plumb _ _ p theta _) ->+ Map.update (f theta) p) grid ps+ where f (Just North) Cross = Just $ Straight Horizontal+ f (Just East) Cross = Just $ Straight Vertical+ f (Just South) Cross = Just $ Straight Horizontal+ f (Just West) Cross = Just $ Straight Vertical+ f _ _ = Nothing++spareParts :: Grid -> [Plumb]+spareParts (Grid _ _ grid) =+ Map.foldWithKey sparePart [] grid++sparePart :: Point -> Tile -> [Plumb] -> [Plumb]+sparePart p (Start col theta) xs = Plumb col (-1) p Nothing (Just theta) : xs+sparePart p (End col theta) xs = Plumb col (-1) p (Just theta) Nothing : xs+sparePart p (Corner theta) xs =+ Plumb Green (-1) p (Just theta) (Just $ bend theta) : xs+sparePart p (Straight Horizontal) xs =+ Plumb Green (-1) p (Just East) (Just West) : xs+sparePart p (Straight Vertical) xs =+ Plumb Green (-1) p (Just North) (Just South) : xs+sparePart p Cross xs =+ Plumb Green (-1) p (Just East) (Just West) :+ Plumb Green (-1) p (Just North) (Just South) : xs++buildIndexMap :: [Plumb] -> Map Point Int+buildIndexMap = foldr (\plumb gridMap -> case plumb of+ Plumb _ i p _ (Just _) -> Map.alter (Just . maybe i (min i)) p gridMap+ Plumb _ _ p _ Nothing -> Map.insert p (-1) gridMap) Map.empty++plumbGrid :: Grid -> PlumbedGrid+plumbGrid grid =+ let plumbs = plumbAllStarts grid+ leaks = mapMaybe plumbLeak plumbs+ indexMap = buildIndexMap $ plumb ++ filter (\(Plumb _ _ _ _ flow) ->+ isNothing flow) spares+ plumb = concat plumbs+ spares = spareParts $ stripPlumbed plumb grid+ in PlumbedGrid (plumb ++ spares) leaks indexMap++nextPosFollowPlumb :: Grid -> Colour -> Point -> Maybe Bearing -> [PrePlumb]+nextPosFollowPlumb grid@(Grid w h _) col start flow =+ dropOutOfBounds $ case reverse <$> plumbStart grid col start flow of+ (EmptyTile, []) -> [PrePlumb col 0 start flow]+ (EmptyTile, ps) -> plumbOn (head ps) : map unPlumb ps+ (Success, ps) -> map unPlumb ps+ _ -> []+ where dropOutOfBounds pps@(PrePlumb _ _ (Pt x y) _:_) =+ if x >= 0 && y >=0 && x < w && y < h then pps else []+ dropOutOfBounds [] = []++neighbours :: Grid -> Colour -> Point -> [[PrePlumb]]+neighbours grid@(Grid _ _ gridMap) col start =+ filter (not . null) $ case Map.lookup start gridMap of+ Just _ -> [nextPosFollowPlumb grid col start Nothing]+ Nothing -> map ((\flow ->+ nextPosFollowPlumb grid col (nextPos flow start) flow) . Just)+ [North,East,South,West]++findCosts ::+ Grid -> Colour -> Point -> Map Point (Int, [PrePlumb])+findCosts grid col start =+ fst $ fromJust $ find (null . snd) $+ iterate explore (Map.empty, [(start, [], -1)])+ where explore (cache, open) =+ foldr update (cache, []) open + update (curr, pps, cost') (cache, open) =+ case fromMaybe (maxBound, []) $ Map.lookup curr cache of+ (cost, _) | cost' < cost ->+ (Map.insert curr (cost', pps) cache,+ map (\pps'@(PrePlumb _ _ curr' _:_) ->+ (curr', pps' ++ pps, cost' + 1))+ (neighbours grid col curr) ++ open)+ _ -> (cache, open)++findGoal ::+ Grid -> Map Point (Int, a) -> Colour -> Maybe (Point, Int, a)+findGoal (Grid _ _ gridMap) costs col =+ fmap (\((a,b),c) -> (a,c,b)) $+ foldr (\(curr,(cost,x)) prevBest -> case prevBest of+ Just best | cost >= snd best -> prevBest+ _ -> Just ((curr,x),cost)) Nothing $+ Map.toList $ Map.mapMaybeWithKey (\curr tile ->+ case tile of+ End col' _ | col' == col -> Map.lookup curr costs+ _ -> Nothing) gridMap++findPath :: Grid -> Colour -> Point -> Maybe ([Plumb], Int)+findPath grid col start =+ let costs = findCosts grid col start+ goal = findGoal grid costs col+ in fmap (\(_,cost,pps) -> (plumbPre $ reverse pps,cost)) goal++plumbPre :: [PrePlumb] -> [Plumb]+plumbPre pps = zipWith3 f pps (tail pps) [0..]+ where f (PrePlumb col _ curr flow) (PrePlumb _ _ _ nextFlow) idx =+ Plumb col idx curr (fmap invert flow) nextFlow++gridHeuristic :: Int -> Grid -> Int+gridHeuristic vol grid = snd $ foldStarts (\col start (grid',heur) ->+ let plumbedLen = length $ snd $ plumbStart grid' col start Nothing+ (path, pathLen) = fromMaybe ([], 1000) $ findPath grid' col start+ remain = min (plumbedLen - vol) 4+ bonus = 9*remain - (remain*remain)+ grid'' = foldr placePlumb grid' path+ in (grid'', heur + 2*bonus + 4*plumbedLen - pathLen)) (grid, 0) grid++pickMove :: Grid -> TileSource -> Point -> Int -> Point+pickMove grid (TileSource (NumberedTile tile _:_)) start vol =+ fst $ head $ sortMoves start vol $ searchMoves grid vol tile++searchMoves :: Grid -> Int -> Tile -> [(Point, Grid)]+searchMoves grid@(Grid w h _) vol tile =+ map (\pt -> (pt, place pt tile grid)) $+ filter (isPlacable pGrid vol) $ liftM2 Pt [0..w-1] [0..h-1]+ where pGrid = plumbGrid grid++sortMoves :: Point -> Int -> [(Point, Grid)] -> [(Point, Grid)]+sortMoves start vol =+ map fst . sortBy (flip compare `on` snd) .+ map (\x -> (,) x $ (+ (distance start (fst x) / (-100.0))) $ fromIntegral $ gridHeuristic vol $ snd x)++distance :: Point -> Point -> Double+distance (Pt x1 y1) (Pt x2 y2) =+ sqrt $ (x*x)+(y*y)+ where x = fromIntegral (x1-x2)+ y = fromIntegral (y1-y2)++placePlumb :: Plumb -> Grid -> Grid+placePlumb (Plumb _ _ curr (Just inflow) (Just flow))+ | inflow == bend flow = placeIfFree curr $ Corner flow+ | inflow == revBend flow = placeIfFree curr $ Corner inflow+ | otherwise = placeIfFree curr Cross+placePlumb _ = id++debugMain :: Grid -> IO ()+debugMain myGrid = do+ clazz <- newClass [+ defMethod' "newTileSource" (\_ -> newObjectDC =<< newTileSource),+ defMethod' "newGrid" (\_ -> newObjectDC myGrid),+ defMethod' "sparePart" (\_ tile ->+ return $ sparePart (Pt 0 0) tile [] :: IO [Plumb])]+ object <- newObject clazz ()+ -- setQtArgs "hsqml-manic" ["-qmljsdebugger=port:9999,block"]+ qml <- getDataFileName "Main.qml"+ runEngineLoop $ defaultEngineConfig {+ initialDocument = fileDocument qml,+ contextObject = Just $ anyObjRef object+ }++newGrid :: Grid+newGrid = Grid 8 8 $ Map.fromList [+ (Pt 4 0,Start Yellow South),+ (Pt 3 7,End Yellow North),+ (Pt 0 3, Start Brown East),+ (Pt 7 4, End Brown West)]++main :: IO ()+main = debugMain newGrid