konami code engage

mario/serverside/src/Lib.hs

@@ -32,6 +32,7 @@ data Account = Account {
   uid :: UUID
 , username :: Text
 , score :: Int
+, color :: String
 } deriving (Eq, Show, Ord, Generic, Typeable)
 
 instance ToJSON Account
@@ -70,10 +71,19 @@ data ScoreUpdate = ScoreUpdate {
 
 instance FromJSON ScoreUpdate
 
+data ColorUpdate = ColorUpdate {
+  newColor :: String
+} deriving (Eq, Show, Generic)
+
+instance FromJSON ColorUpdate
+
 type API = "register" :> ReqBody '[JSON] AccountReq :> Post '[JSON] Account
       :<|> "users" :> Get '[JSON] (Set Account)
-      :<|> "score" :> Capture "uuid" UUID 
-                   :> ReqBody '[JSON] ScoreUpdate 
+      :<|> "color" :> Capture "uuid" UUID
+                   :> ReqBody '[JSON] ColorUpdate
+                   :> Put '[JSON] ()
+      :<|> "score" :> Capture "uuid" UUID
+                   :> ReqBody '[JSON] ScoreUpdate
                    :> Put '[JSON] ()
 
 -- TODO: 
@@ -82,11 +92,11 @@ type API = "register" :> ReqBody '[JSON] AccountReq :> Post '[JSON] Account
 -- - set up a working copy on a subdomain with an oncommit reload hook
 
 server :: AcidState AccountsState -> Server API
-server state = register :<|> users :<|> score
+server state = register :<|> users :<|> color :<|> score
   where register :: AccountReq -> Handler Account
         register (AccountReq uname) = do
           uuid <- liftIO Uuid.nextRandom
-          let newAccount = Account uuid uname 0
+          let newAccount = Account uuid uname 0 "red"
 
           liftIO $ update state (AddUser newAccount)
           return newAccount
@@ -96,6 +106,15 @@ server state = register :<|> users :<|> score
           liftIO $ putStrLn "users called"
           liftIO $ query state QueryState
 
+        color :: UUID -> ColorUpdate -> Handler ()
+        color uuid (ColorUpdate newColor) = do
+          users <- liftIO $ query state QueryState
+          case filter ((==) uuid . uid) $ Set.toList users of
+            [] -> return ()
+            user:xs -> do
+              liftIO $ update state (UpdateUser user (user { color = newColor }))
+              return ()
+
         score :: UUID -> ScoreUpdate -> Handler ()
         score uuid (ScoreUpdate newScore) = do
           users <- liftIO $ query state QueryState

mario/serverside/src/WS.hs

@@ -58,7 +58,7 @@ broadcast uuid message state = forM_ accts sendToClient
 hasAccount :: AcidState AccountsState -> UUID -> IO Bool
 hasAccount accounts uuid = do
   users <- liftIO $ query accounts QueryState
-  return . not . null $ filter (\(Account uid _ _) -> uuid == uid) (Set.toList users)
+  return . not . null $ filter (\(Account uid _ _ _) -> uuid == uid) (Set.toList users)
 
 application :: TVar WSState -> AcidState AccountsState -> W.ServerApp
 application clients accounts pending = do

mario/src/Main.re

@@ -59,6 +59,7 @@ module Canvas = {
   [@bs.send] external getContext2d: (Dom.element, [@bs.as "2d"] _) => context = "getContext";
   [@bs.send] external fillRectFloat: (context, float, float, float, float) => unit = "fillRect";
   [@bs.send] external fillRectInt: (context, int, int, int, int) => unit = "fillRect";
+  [@bs.send] external drawImage: (context, Dom.element, int, int, int, int) => unit = "drawImage";
 
   [@bs.send] external clearRect: (context, int, int, int, int) => unit = "";
   [@bs.send] external strokeRect: (context, int, int, int, int) => unit = "";
@@ -75,7 +76,8 @@ type world = {
   heroes: list(hero),
   viewport: fourAxisElement(float),
   scene: scene,
-  lastAnimationTime: option(int)
+  lastAnimationTime: option(int),
+  recentKeys: list(string),
 }
 and hero = {
   color: string,
@@ -98,13 +100,51 @@ and scene = {
   w: int,
   h: int,
   leftClicked: bool,
-  rightClicked: bool
+  rightClicked: bool,
+  skyImage: option(Dom.element),
 };
 
 let canHeroJump = (hero: hero) => {
   hero.position.vy === 0.0;
 }
 
+let setRecentKeys = (world: world, newKey: string) => {
+  let newRecent = List.append(world.recentKeys, [newKey]);
+  let recentKeys = if (List.length(newRecent) > 10) {
+    List.tl(newRecent);
+  } else {
+    newRecent;
+  };
+  {...world, recentKeys: recentKeys};
+}
+
+let didKonami = (recentKeys: list(string)) => {
+  recentKeys == [
+    "ArrowUp",
+    "ArrowUp",
+    "ArrowDown",
+    "ArrowDown",
+    "ArrowLeft",
+    "ArrowRight",
+    "ArrowLeft",
+    "ArrowRight",
+    "b",
+    "a",
+  ];
+}
+
+let setSkyImage = (world: world) => {
+  let skyImage = if (world.scene.skyImage == None) {
+    let pics = HtmlCollection.toArray(Document.getElementsByClassName("deadmeme", document));
+    Some(pics[Random.int(Array.length(pics))]);
+  } else {
+    world.scene.skyImage;
+  };
+  {...world, scene: {...world.scene,
+      skyImage: skyImage
+  }};
+}
+
 let paintColor = (elementType: elementType): string => {
   switch(elementType) {
   | Floor => "#97FF29"
@@ -118,6 +158,7 @@ let stone = (coord : int): envElement => {
 };
 
 let generateRandomEnvironment = (length: int): array(array(envElement)) => {
+  Random.self_init();
   let baseElement = {coordinate: 0, elementType: Floor};
   let m = Array.make_matrix(length, 20, baseElement);
   m[10][1] = stone(3);
@@ -135,9 +176,20 @@ let generateRandomEnvironment = (length: int): array(array(envElement)) => {
 let tileSize = 40.0;
 let heroSize = tileSize /. 2.0;
 
+let drawSky = (world: world): unit => {
+  open Canvas;
+  fillStyleSet(world.scene.ctx, "#008AC5");
+  Canvas.fillRectInt(world.scene.ctx, 0, 0, world.scene.w, world.scene.h);
+  switch (world.scene.skyImage) {
+  | None => ();
+  | Some(pic) => Canvas.drawImage(world.scene.ctx, pic, 250, 100, world.scene.w - 500, world.scene.h - 200);
+  };
+}
+
 let constrain = (amt: float, low: float, high: float): float => {
   max(low, min(high, amt))
 }
+
 let constrainLeft = (amt: float, low: float): float => {
   max(low, amt)
 }
@@ -150,8 +202,7 @@ let paint = (world: world): unit => {
   let envPaintEnd = int_of_float((float_of_int(world.scene.w) +. world.viewport.x) /. tileSize) + 1;
 
   /* Draw the sky */
-  fillStyleSet(world.scene.ctx, "#008AC5");
-  Canvas.fillRectInt(world.scene.ctx, 0, 0, world.scene.w, world.scene.h);
+  drawSky(world);
 
   /* Draw the tiles */
   ArrayUtil.iterRange(envPaintStart, envPaintEnd, world.env, (idx, tiles) => {
@@ -327,6 +378,12 @@ let mainLoop = (world: world) => {
   Element.addKeyUpEventListener((e) => {
     open KeyboardEvent;
 
+    currentWorld := setRecentKeys(currentWorld^, key(e));
+
+    if (didKonami(currentWorld^.recentKeys)) {
+      currentWorld := setSkyImage(currentWorld^);
+    };
+
     if (key(e) === "ArrowRight") {
       currentWorld := {...currentWorld^, scene: {...currentWorld^.scene,
         rightClicked: false
@@ -377,9 +434,11 @@ let initialize = (): option(world) => {
           w: canvasWidth,
           h: canvasHeight,
           leftClicked: false,
-          rightClicked: false
+          rightClicked: false,
+          skyImage: None
         },
-        lastAnimationTime: None
+        lastAnimationTime: None,
+        recentKeys: []
       });
     }
   };