packages feed

hscharm (empty) → 0.0.1

raw patch · 9 files changed

+1485/−0 lines, 9 filesdep +basedep +randomdep +random-shufflesetup-changed

Dependencies added: base, random, random-shuffle

Files

+ LICENSE.md view
@@ -0,0 +1,23 @@+FreeBSD License++Copyright 2011 YelloSoft. All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.+2. 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.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS "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 AUTHORS 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
+ charm/lib/charm.c view
@@ -0,0 +1,527 @@+// Copyright (C) YelloSoft++#include "charm.h"+#include <sys/ioctl.h>+#include <termios.h>+#include <unistd.h>+#include <signal.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>++// ANSI Escape Codes+// http://en.wikipedia.org/wiki/ANSI_escape_code++// Terminal information+// http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man4/tty.4.html++// Disabling echo+// http://www.gnu.org/s/hello/manual/libc/getpass.html++int pos_x;+int pos_y;++int get_width(void) {+  struct winsize ws;+  (void) ioctl(0, TIOCGWINSZ, &ws);++  return (int) ws.ws_col;+}++int get_height(void) {+  struct winsize ws;+  (void) ioctl(0, TIOCGWINSZ, &ws);++  return (int) ws.ws_row;+}++void cursor_off(void) {+  printf("\033[?25l");+  (void) fflush(stdout);+}++void cursor_on(void) {+  printf("\033[?25h");+  (void) fflush(stdout);+}++void echo_off(void) {+  struct termios term;+  (void) tcgetattr(fileno(stdout), &term);+  term.c_lflag &= (unsigned long) ~ECHO;+  (void) tcsetattr(fileno(stdout), TCSAFLUSH, &term);+}++void echo_on(void) {+  struct termios term;+  (void) tcgetattr(fileno(stdout), &term);+  term.c_lflag |= ECHO;+  (void) tcsetattr(fileno(stdout), TCSAFLUSH, &term);+}++void raw_on(void) {+  struct termios term;+  (void) tcgetattr(fileno(stdout), &term);+  term.c_lflag &= (unsigned long) ~ICANON;+  (void) tcsetattr(fileno(stdout), TCSAFLUSH, &term);+}++void raw_off(void) {+  struct termios term;+  (void) tcgetattr(fileno(stdout), &term);+  term.c_lflag |= ICANON;+  (void) tcsetattr(fileno(stdout), TCSAFLUSH, &term);+}++void blocking_off(void) {+  struct termios term;+  (void) tcgetattr(fileno(stdout), &term);+  term.c_cc[VMIN] = (cc_t) 0;+  (void) tcsetattr(fileno(stdout), TCSAFLUSH, &term);+}++void blocking_on(void) {+  struct termios term;+  (void) tcgetattr(fileno(stdout), &term);+  term.c_cc[VMIN] = (cc_t) 1;+  (void) tcsetattr(fileno(stdout), TCSAFLUSH, &term);+}++int get_x(void) {+  return pos_x;+}++int get_y(void) {+  return pos_y;+}++// (0, 0) = top left+// (width - 1, 0) = top right+// (0, height - 1) = bottom left+// (width - 1, height - 1) = bottom right+void move_cursor(int x, int y) {+  pos_x = x;+  pos_y = y;+  printf("\033[%d;%dH", y + 1, x + 1);+  (void) fflush(stdout);+}++void blot_char(char c) {+  if (c == '\n') {+    pos_y++;+    move_cursor(0, pos_y);+  } else {+    (void) putchar(c);+    (void) fflush(stdout);+    pos_x++;+  }+}++void blot_string(const char *s) {+  int i;++  for (i = 0; i < (int) strlen(s); i++) {+    blot_char(s[i]);+  }+}++void hcenter_string(const char *s) {+  move_cursor((get_width() - (int) strlen(s)) / 2, pos_y);+  blot_string(s);+}++void vcenter_string(const char *s) {+  move_cursor((get_width() - (int) strlen(s)) / 2 - 1, get_height() / 2 - 1);+  blot_string(s);+}++void clear_screen(void) {+  printf("\033[2J");+  (void) fflush(stdout);+}++void __attribute__((noreturn)) handle_signal(int __attribute__((+      unused)) /*@unused@*/ signal) {+  end_charm();+  exit(0);+}++void start_charm(void) {+  (void) signal(SIGINT, handle_signal);++  cursor_off();+  echo_off();+  raw_on();+  blocking_off();+  move_cursor(0, 0);+  clear_screen();+}++void end_charm(void) {+  move_cursor(0, 0);+  clear_screen();+  blocking_on();+  raw_off();+  echo_on();+  cursor_on();+}++key parse_key(char *buf) {+  switch (buf[0]) {+  case '\x7f':+  case '\b':+    return KEY_BACKSPACE;++  case '\t':+    return KEY_TAB;++  case '\n':+    return KEY_NEWLINE;++  case ' ':+    return KEY_SPACE;++  case '!':+    return KEY_EXCLAMATION;++  case '\"':+    return KEY_DOUBLE_QUOTE;++  case '#':+    return KEY_HASH;++  case '$':+    return KEY_DOLLAR;++  case '%':+    return KEY_PERCENT;++  case '&':+    return KEY_AMPERSAND;++  case '\'':+    return KEY_SINGLE_QUOTE;++  case '(':+    return KEY_LEFT_PAREN;++  case ')':+    return KEY_RIGHT_PAREN;++  case '*':+    return KEY_ASTERISK;++  case '+':+    return KEY_PLUS;++  case ',':+    return KEY_COMMA;++  case '-':+    return KEY_MINUS;++  case '.':+    return KEY_PERIOD;++  case '/':+    return KEY_SLASH;++  case '0':+    return KEY_0;++  case '1':+    return KEY_1;++  case '2':+    return KEY_2;++  case '3':+    return KEY_3;++  case '4':+    return KEY_4;++  case '5':+    return KEY_5;++  case '6':+    return KEY_6;++  case '7':+    return KEY_7;++  case '8':+    return KEY_8;++  case '9':+    return KEY_9;++  case ':':+    return KEY_COLON;++  case ';':+    return KEY_SEMICOLON;++  case '<':+    return KEY_LESS_THAN;++  case '=':+    return KEY_EQUALS;++  case '>':+    return KEY_GREATER_THAN;++  case '?':+    return KEY_QUESTION;++  case '@':+    return KEY_AT;++  case 'A':+    return KEY_CAPITAL_A;++  case 'B':+    return KEY_CAPITAL_B;++  case 'C':+    return KEY_CAPITAL_C;++  case 'D':+    return KEY_CAPITAL_D;++  case 'E':+    return KEY_CAPITAL_E;++  case 'F':+    return KEY_CAPITAL_F;++  case 'G':+    return KEY_CAPITAL_G;++  case 'H':+    return KEY_CAPITAL_H;++  case 'I':+    return KEY_CAPITAL_I;++  case 'J':+    return KEY_CAPITAL_J;++  case 'K':+    return KEY_CAPITAL_K;++  case 'L':+    return KEY_CAPITAL_L;++  case 'M':+    return KEY_CAPITAL_M;++  case 'N':+    return KEY_CAPITAL_N;++  case 'O':+    return KEY_CAPITAL_O;++  case 'P':+    return KEY_CAPITAL_P;++  case 'Q':+    return KEY_CAPITAL_Q;++  case 'R':+    return KEY_CAPITAL_R;++  case 'S':+    return KEY_CAPITAL_S;++  case 'T':+    return KEY_CAPITAL_T;++  case 'U':+    return KEY_CAPITAL_U;++  case 'V':+    return KEY_CAPITAL_V;++  case 'W':+    return KEY_CAPITAL_W;++  case 'X':+    return KEY_CAPITAL_X;++  case 'Y':+    return KEY_CAPITAL_Y;++  case 'Z':+    return KEY_CAPITAL_Z;++  case '[':+    return KEY_LEFT_BRACKET;++  case '\\':+    return KEY_BACKSLASH;++  case ']':+    return KEY_RIGHT_BRACKET;++  case '^':+    return KEY_CARET;++  case '_':+    return KEY_UNDERSCORE;++  case '`':+    return KEY_BACKTICK;++  case 'a':+    return KEY_A;++  case 'b':+    return KEY_B;++  case 'c':+    return KEY_C;++  case 'd':+    return KEY_D;++  case 'e':+    return KEY_E;++  case 'f':+    return KEY_F;++  case 'g':+    return KEY_G;++  case 'h':+    return KEY_H;++  case 'i':+    return KEY_I;++  case 'j':+    return KEY_J;++  case 'k':+    return KEY_K;++  case 'l':+    return KEY_L;++  case 'm':+    return KEY_M;++  case 'n':+    return KEY_N;++  case 'o':+    return KEY_O;++  case 'p':+    return KEY_P;++  case 'q':+    return KEY_Q;++  case 'r':+    return KEY_R;++  case 's':+    return KEY_S;++  case 't':+    return KEY_T;++  case 'u':+    return KEY_U;++  case 'v':+    return KEY_V;++  case 'w':+    return KEY_W;++  case 'x':+    return KEY_X;++  case 'y':+    return KEY_Y;++  case 'z':+    return KEY_Z;++  case '{':+    return KEY_LEFT_BRACE;++  case '|':+    return KEY_PIPE;++  case '}':+    return KEY_RIGHT_BRACE;++  case '~':+    return KEY_TILDE;++  case '\x1b':+    switch (buf[1]) {+    case '\0':+      return KEY_ESCAPE;++    case '[':+      switch (buf[2]) {+      case 'A':+        return KEY_UP;++      case 'B':+        return KEY_DOWN;++      case 'C':+        return KEY_RIGHT;++      case 'D':+        return KEY_LEFT;+      }+    }++  /*@fallthrough@*/+  default:+    return KEY_UNKNOWN;+  }+}++key get_key(void) {+  int i;++  char *buf = (char *) malloc(3 * sizeof(char));++  if (buf == NULL) {+    return KEY_UNKNOWN;+  }++  buf[0] = '\0';+  buf[1] = '\0';+  buf[2] = '\0';++  i = 0;++  char c = '\0';++  ssize_t n = 0;++  // Read at least one character.+  while (n < 1) {+    n = read(fileno(stdin), &c, 1);+  }++  while (i < 3 && n > 0) {+    buf[i++] = c;+    n = read(fileno(stdin), &c, 1);+  }++  key k = parse_key(buf);++  free(buf);++  return k;+}
+ charm/lib/charm.h view
@@ -0,0 +1,157 @@+#pragma once++// Copyright (C) YelloSoft++#define CHARM_VERSION "0.0.1"++extern int pos_x;+extern int pos_y;++int get_width(void);+int get_height(void);++void cursor_off(void);+void cursor_on(void);++void echo_off(void);+void echo_on(void);++void raw_on(void);+void raw_off(void);++void blocking_off(void);+void blocking_on(void);++int get_x(void);+int get_y(void);+void move_cursor(int x, int y);+void blot_char(char c);+void blot_string(const char *s);+void hcenter_string(const char *s);+void vcenter_string(const char *s);++void clear_screen(void);++void handle_signal(int signal);+void start_charm(void);+void end_charm(void);++typedef enum {+  KEY_BACKSPACE,+  KEY_TAB,+  KEY_NEWLINE,++  KEY_SPACE,+  KEY_EXCLAMATION,+  KEY_DOUBLE_QUOTE,+  KEY_HASH,+  KEY_DOLLAR,+  KEY_PERCENT,+  KEY_AMPERSAND,+  KEY_SINGLE_QUOTE,+  KEY_LEFT_PAREN,+  KEY_RIGHT_PAREN,+  KEY_ASTERISK,+  KEY_PLUS,+  KEY_COMMA,+  KEY_MINUS,+  KEY_PERIOD,+  KEY_SLASH,++  KEY_0,+  KEY_1,+  KEY_2,+  KEY_3,+  KEY_4,+  KEY_5,+  KEY_6,+  KEY_7,+  KEY_8,+  KEY_9,++  KEY_COLON,+  KEY_SEMICOLON,+  KEY_LESS_THAN,+  KEY_EQUALS,+  KEY_GREATER_THAN,+  KEY_QUESTION,+  KEY_AT,++  KEY_CAPITAL_A,+  KEY_CAPITAL_B,+  KEY_CAPITAL_C,+  KEY_CAPITAL_D,+  KEY_CAPITAL_E,+  KEY_CAPITAL_F,+  KEY_CAPITAL_G,+  KEY_CAPITAL_H,+  KEY_CAPITAL_I,+  KEY_CAPITAL_J,+  KEY_CAPITAL_K,+  KEY_CAPITAL_L,+  KEY_CAPITAL_M,+  KEY_CAPITAL_N,+  KEY_CAPITAL_O,+  KEY_CAPITAL_P,+  KEY_CAPITAL_Q,+  KEY_CAPITAL_R,+  KEY_CAPITAL_S,+  KEY_CAPITAL_T,+  KEY_CAPITAL_U,+  KEY_CAPITAL_V,+  KEY_CAPITAL_W,+  KEY_CAPITAL_X,+  KEY_CAPITAL_Y,+  KEY_CAPITAL_Z,++  KEY_LEFT_BRACKET,+  KEY_BACKSLASH,+  KEY_RIGHT_BRACKET,+  KEY_CARET,+  KEY_UNDERSCORE,+  KEY_BACKTICK,++  KEY_A,+  KEY_B,+  KEY_C,+  KEY_D,+  KEY_E,+  KEY_F,+  KEY_G,+  KEY_H,+  KEY_I,+  KEY_J,+  KEY_K,+  KEY_L,+  KEY_M,+  KEY_N,+  KEY_O,+  KEY_P,+  KEY_Q,+  KEY_R,+  KEY_S,+  KEY_T,+  KEY_U,+  KEY_V,+  KEY_W,+  KEY_X,+  KEY_Y,+  KEY_Z,++  KEY_LEFT_BRACE,+  KEY_PIPE,+  KEY_RIGHT_BRACE,+  KEY_TILDE,++  KEY_UP,+  KEY_DOWN,+  KEY_RIGHT,+  KEY_LEFT,++  KEY_ESCAPE,++  KEY_UNKNOWN+} key;++key parse_key(char *buf);+key get_key(void);
+ hscharm.cabal view
@@ -0,0 +1,66 @@+name:           hscharm+version:        0.0.1+category:       Math+synopsis:       Wau codec+description:    A base unary encoder/decoder+license:        BSD3+license-file:   LICENSE.md+author:         Andrew Pennebaker+maintainer:     andrew.pennebaker@gmail.com+build-type:     Simple+cabal-version:  >=1.8++source-repository head+  type:     git+  location: git://github.com/mcandre/hscharm.git++library+  build-depends:+    base >= 4.3.1.0 && < 5++  exposed-modules: HsCharm++  ghc-options: -Wall -fwarn-tabs+  hs-source-dirs: src+  c-sources: charm/lib/charm.c+  install-includes: charm/lib/charm.h++executable hellocharm+  build-depends:+    base >= 4.3.1.0 && < 5++  other-modules: HsCharm++  ghc-options: -Wall -fwarn-tabs+  main-is: HelloCharm.hs+  hs-source-dirs: src+  c-sources: charm/lib/charm.c+  install-includes: charm/lib/charm.h++executable rl+  build-depends:+    base           >= 4.3.1.0 && < 5,+    random         >= 1.1 && < 2,+    random-shuffle >= 0.0.4 && < 0.0.5++  other-modules: HsCharm++  ghc-options: -Wall -fwarn-tabs+  main-is: RL.hs+  hs-source-dirs: src+  c-sources: charm/lib/charm.c+  install-includes: charm/lib/charm.h++executable ddr+  build-depends:+    base           >= 4.3.1.0 && < 5,+    random         >= 1.1 && < 2,+    random-shuffle >= 0.0.4 && < 0.0.5++  other-modules: HsCharm++  ghc-options: -Wall -fwarn-tabs+  main-is: DDR.hs+  hs-source-dirs: src+  c-sources: charm/lib/charm.c+  install-includes: charm/lib/charm.h
+ src/DDR.hs view
@@ -0,0 +1,73 @@+module Main where++import qualified System.Random as Random+import qualified System.Random.Shuffle as Shuffle++import HsCharm++import Control.Monad (when)+import Text.Printf (printf)++data Game = Game {+  score :: Int,+  delta :: Int+  }++drawScore :: Int -> IO ()+drawScore s = do+  moveCursor 0 2+  hCenterString $ printf "SCORE %04d" s++drawArrow :: Key -> IO ()+drawArrow a = do+  moveCursor 0 4++  hCenterString $ case a of+    KeyUp -> "^"+    KeyDown -> "v"+    KeyRight -> ">"+    KeyLeft -> "<"+    _ -> ""++drawHoot :: Bool -> IO ()+drawHoot b = do+  moveCursor 0 6++  hCenterString $ if b then "GOOD!" else "BAD! "++loop :: Game -> IO ()+loop g = do+  drawScore $ score g++  stdGen <- Random.getStdGen++  let arrow = head $ Shuffle.shuffle' [KeyUp, KeyDown, KeyRight, KeyLeft] 4 stdGen++  drawArrow arrow++  k <- getKey++  when (k `notElem` [KeyEscape, KeyQ])+    (do+       let match = arrow == k++       drawHoot match++       let g' = g { score = score g + (if match then 1 else -1) }++       loop g')++main :: IO ()+main = do+ startCharm++ hCenterString "DDR: How fast can you play?"++ let g = Game {+       score = 0,+       delta = 0+       }++ loop g++ endCharm
+ src/HelloCharm.hs view
@@ -0,0 +1,18 @@+module Main where++import HsCharm++react :: Key -> IO ()+react KeyEscape = return ()+react KeyQ = return ()+react _ = getKey >>= react++main :: IO ()+main = do+  startCharm++  vCenterString "Hello Charm! Press Escape, q, or Control-C to quit."++  getKey >>= react++  endCharm
+ src/HsCharm.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | HsCharm wraps charm, a minimal ncurses-like terminal UI library+module HsCharm (+  charmVersion,++  getWidth,+  getHeight,++  cursorOff,+  cursorOn,++  echoOff,+  echoOn,++  rawOn,+  rawOff,++  getCursor,+  moveCursor,+  blotChar,+  blotString,+  hCenterString,+  vCenterString,++  clearScreen,++  handleSignal,++  startCharm,+  endCharm,++  getKey,+  Key(+    KeyBackspace,+    KeyTab,+    KeyNewline,++    KeySpace,+    KeyExclamation,+    KeyDoubleQuote,+    KeyHash,+    KeyDollar,+    KeyPercent,+    KeyAmpersand,+    KeySingleQuote,+    KeyLeftParen,+    KeyRightParen,+    KeyAsterisk,+    KeyPlus,+    KeyComma,+    KeyMinus,+    KeyPeriod,+    KeySlash,++    KeyZero,+    KeyOne,+    KeyTwo,+    KeyThree,+    KeyFour,+    KeyFive,+    KeySix,+    KeySeven,+    KeyEight,+    KeyNine,++    KeyColon,+    KeySemicolon,+    KeyLessThan,+    KeyEquals,+    KeyGreaterThan,+    KeyQuestion,+    KeyAt,++    KeyCapitalA,+    KeyCapitalB,+    KeyCapitalC,+    KeyCapitalD,+    KeyCapitalE,+    KeyCapitalF,+    KeyCapitalG,+    KeyCapitalH,+    KeyCapitalI,+    KeyCapitalJ,+    KeyCapitalK,+    KeyCapitalL,+    KeyCapitalM,+    KeyCapitalN,+    KeyCapitalO,+    KeyCapitalP,+    KeyCapitalQ,+    KeyCapitalR,+    KeyCapitalS,+    KeyCapitalT,+    KeyCapitalU,+    KeyCapitalV,+    KeyCapitalW,+    KeyCapitalX,+    KeyCapitalY,+    KeyCapitalZ,++    KeyLeftBracket,+    KeyBackslash,+    KeyRightBracket,+    KeyCaret,+    KeyUnderscore,+    KeyBacktick,++    KeyA,+    KeyB,+    KeyC,+    KeyD,+    KeyE,+    KeyF,+    KeyG,+    KeyH,+    KeyI,+    KeyJ,+    KeyK,+    KeyL,+    KeyM,+    KeyN,+    KeyO,+    KeyP,+    KeyQ,+    KeyR,+    KeyS,+    KeyT,+    KeyU,+    KeyV,+    KeyW,+    KeyX,+    KeyY,+    KeyZ,++    KeyLeftBrace,+    KeyPipe,+    KeyRightBrace,+    KeyTilde,++    KeyUp,+    KeyDown,+    KeyRight,+    KeyLeft,++    KeyEscape,+    KeyUnknown+    )+  ) where++import Foreign.C++-- | charmVersion is semver.+charmVersion :: String+charmVersion = "0.0.1"++-- | getWidth queries terminal width.+foreign import ccall "charm.h get_width" getWidth :: IO Int++-- | getHeight queries terminal height+foreign import ccall "charm.h get_height" getHeight :: IO Int++-- | cursorOff hides the cursor.+foreign import ccall "charm.h cursor_off" cursorOff :: IO ()++-- | cursorOn shows the cursor.+foreign import ccall "charm.h cursor_on" cursorOn :: IO ()++-- | echoOff disables key echoing.+foreign import ccall "charm.h echo_off" echoOff :: IO ()++-- | echoOn enables key echoing.+foreign import ccall "charm.h echo_on" echoOn :: IO ()++-- | rawOn enables raw manipulation.+foreign import ccall "charm.h raw_on" rawOn :: IO ()++-- | rawOff disables raw manipulation.+foreign import ccall "charm.h raw_off" rawOff :: IO ()++-- | getX gets the cursor X coordinate.+foreign import ccall "charm.h get_x" getX :: IO Int++-- | getY gets the cursor Y coordinate.+foreign import ccall "charm.h get_y" getY :: IO Int++-- | getCursor queries the cursor position.+getCursor :: IO (Int, Int)+getCursor = do+  x <- getX+  y <- getY++  return (x, y)++-- | moveCursor repositions the cursor.+foreign import ccall "charm.h move_cursor" moveCursor :: Int -> Int -> IO ()++-- | blotChar renders a chacter.+foreign import ccall "charm.h blot_char" blotChar :: Char -> IO ()++-- | blogString' renders a C string.+foreign import ccall "charm.h blot_string" blotString' :: CString -> IO ()++-- | blotString renders a string message.+blotString :: String -> IO ()+blotString s = do+  s' <- newCString s+  blotString' s'++-- | hCenterString' centers C strings horizontally.+foreign import ccall "charm.h hcenter_string" hCenterString' :: CString -> IO ()++-- | hCenterString displays a string centered horizontally on screen.+hCenterString :: String -> IO ()+hCenterString s = do+  s' <- newCString s+  hCenterString' s'++-- | vCenterString' centers C strings vertically.+foreign import ccall "charm.h vcenter_string" vCenterString' :: CString -> IO ()++-- | vCenterString displays a string centered vertically on screen.+vCenterString :: String -> IO ()+vCenterString s = do+  s' <- newCString s+  vCenterString' s'++-- | clearScreen wipes the terminal display.+foreign import ccall "charm.h clear_screen" clearScreen :: IO ()++-- | handleSignal dispatches events.+foreign import ccall "charm.h handle_signal" handleSignal :: Int -> IO ()++-- | startCharm prepares the charm session.+foreign import ccall "charm.h start_charm" startCharm :: IO ()++-- | endCharm tears down charm session resources.+foreign import ccall "charm.h end_charm" endCharm :: IO ()++-- | getKey' queries keyboard input.+foreign import ccall "charm.h get_key" getKey' :: IO Int++-- | Key models keybard input.+data Key+  = KeyBackspace+  | KeyTab+  | KeyNewline++  | KeySpace+  | KeyExclamation+  | KeyDoubleQuote+  | KeyHash+  | KeyDollar+  | KeyPercent+  | KeyAmpersand+  | KeySingleQuote+  | KeyLeftParen+  | KeyRightParen+  | KeyAsterisk+  | KeyPlus+  | KeyComma+  | KeyMinus+  | KeyPeriod+  | KeySlash++  | KeyZero+  | KeyOne+  | KeyTwo+  | KeyThree+  | KeyFour+  | KeyFive+  | KeySix+  | KeySeven+  | KeyEight+  | KeyNine++  | KeyColon+  | KeySemicolon+  | KeyLessThan+  | KeyEquals+  | KeyGreaterThan+  | KeyQuestion+  | KeyAt++  | KeyCapitalA+  | KeyCapitalB+  | KeyCapitalC+  | KeyCapitalD+  | KeyCapitalE+  | KeyCapitalF+  | KeyCapitalG+  | KeyCapitalH+  | KeyCapitalI+  | KeyCapitalJ+  | KeyCapitalK+  | KeyCapitalL+  | KeyCapitalM+  | KeyCapitalN+  | KeyCapitalO+  | KeyCapitalP+  | KeyCapitalQ+  | KeyCapitalR+  | KeyCapitalS+  | KeyCapitalT+  | KeyCapitalU+  | KeyCapitalV+  | KeyCapitalW+  | KeyCapitalX+  | KeyCapitalY+  | KeyCapitalZ++  | KeyLeftBracket+  | KeyBackslash+  | KeyRightBracket+  | KeyCaret+  | KeyUnderscore+  | KeyBacktick++  | KeyA+  | KeyB+  | KeyC+  | KeyD+  | KeyE+  | KeyF+  | KeyG+  | KeyH+  | KeyI+  | KeyJ+  | KeyK+  | KeyL+  | KeyM+  | KeyN+  | KeyO+  | KeyP+  | KeyQ+  | KeyR+  | KeyS+  | KeyT+  | KeyU+  | KeyV+  | KeyW+  | KeyX+  | KeyY+  | KeyZ++  | KeyLeftBrace+  | KeyPipe+  | KeyRightBrace+  | KeyTilde+  | KeyUp+  | KeyDown+  | KeyRight+  | KeyLeft++  | KeyEscape+  | KeyUnknown++  deriving (Eq, Ord, Enum, Show)++-- | getKey queries key presses.+getKey :: IO Key+getKey = do+  k <- getKey'+  return (toEnum k :: Key)
+ src/RL.hs view
@@ -0,0 +1,255 @@+-- Roguelike+module Main where++import qualified System.Random as Random+import qualified System.Random.Shuffle as Shuffle++import HsCharm++import Control.Monad (when, replicateM)+import Data.List (find, delete, intercalate)++data Game = Game {+  width :: Int,+  height :: Int,+  messages :: [String],+  level :: [[Monster]],+  rogue :: Monster,+  monsters :: [Monster]+  }++defaultGame :: Game+defaultGame = Game {+  width = 80,+  height = 24 - messageSpace,+  messages = [],+  level = replicate (24 - messageSpace) (replicate 80 defaultFloor),+  rogue = defaultRogue,+  monsters = []+  }++voicemail :: Game -> [String]+voicemail = take 2 . messages++data Monster = Monster {+  symbol :: String,+  loc :: (Int, Int),+  impassible :: Bool,+  hp :: Int+  } deriving (Eq)++instance Show Monster where+  show = symbol++defaultFloor :: Monster+defaultFloor = Monster {+  symbol = " ",+  loc = (0, 0),+  impassible = False,+  hp = 0+  }++defaultWall :: Monster+defaultWall = Monster {+  symbol = "#",+  loc = (0, 0),+  impassible = True,+  hp = 0+  }++defaultRogue :: Monster+defaultRogue = Monster {+  symbol = "@",+  loc = (0, 0),+  impassible = True,+  hp = 10+  }++defaultZombie :: Monster+defaultZombie = Monster {+  symbol = "z",+  loc = (0, 0),+  impassible = True,+  hp = 1+  }++cellAt :: Game -> (Int, Int) -> Monster+cellAt g (x, y) = (level g !! y) !! x++thingAt :: Game -> (Int, Int) -> Monster+thingAt g p = case find ((p ==) . loc) (monsters g) of+  Just m -> m+  _ -> cellAt g p++attack :: Game -> Monster -> IO Game+attack g m = case symbol m of+  "#" -> return g { messages = "Immobile wall.":voicemail g }+  "z" -> do+    let m' = m { hp = hp m - 1 }+    let ms = delete m (monsters g)+    return g {+      monsters = if hp m' == 0 then ms else m':ms,+      messages = "You hit a zombie.":voicemail g+      }+  _ -> return g++move :: Game -> Key -> IO Game+move g KeyUp+  | y == 0 = return $ g { messages = "Edge of the world.":voicemail g }+  | impassible c = attack g c+  | otherwise = return $ g {+    rogue = r { loc = (x, y - 1) },+    messages = "You moved up!":voicemail g+    }+  where+    r = rogue g+    (x, y) = loc r+    c = thingAt g (x, y - 1)++move g KeyDown+  | y == height g - 1 = return $ g { messages = "Edge of the world.":voicemail g }+  | impassible c = attack g c+  | otherwise = return $ g {+    rogue = r { loc = (x, y + 1) },+    messages = "You moved down!":voicemail g+    }+  where+    r = rogue g+    (x, y) = loc r+    c = thingAt g (x, y + 1)++move g KeyRight+  | x == width g - 1 = return $ g { messages = "Edge of the world.":voicemail g }+  | impassible c = attack g c+  | otherwise = return $ g {+    rogue = r { loc = (x + 1, y) },+    messages = "You moved right!":voicemail g+    }+  where+    r = rogue g+    (x, y) = loc r+    c = thingAt g (x + 1, y)++move g KeyLeft+  | x == 0 = return $ g { messages = "Edge of the world.":voicemail g }+  | impassible c = attack g c+  | otherwise = return $ g {+    rogue = r { loc = (x - 1, y) },+    messages = "You moved left!":voicemail g+    }+  where+    r = rogue g+    (x, y) = loc r+    c = thingAt g (x - 1, y)++move g _ = return g++messageSpace :: Int+messageSpace = 3++blotMessages :: [String] -> Int -> IO ()+blotMessages [] _ = return ()+blotMessages (m:ms) row = do+  moveCursor 0 row+  hCenterString m+  blotMessages ms (row - 1)++blotLevel :: [[Monster]] -> IO ()+blotLevel lev = do+  moveCursor 0 0+  (blotString . intercalate "\n" . map (intercalate "" . map show)) lev++blotMonster :: Monster -> IO ()+blotMonster m = do+  let (x, y) = loc m+  moveCursor x y+  blotString $ show m++loop :: Game -> IO ()+loop g = do+  blotLevel $ level g++  mapM_ blotMonster (monsters g)++  blotMonster $ rogue g++  -- Clear messages+  blotMessages (replicate 3 $ intercalate "" $ replicate (width g) " ") (height g + messageSpace - 1)++  blotMessages (reverse $ messages g) (height g + messageSpace - 1)++  k <- getKey++  when (k `notElem` [KeyEscape, KeyQ])+    (do+        g' <- if k `elem` [KeyUp, KeyDown, KeyRight, KeyLeft]+              then move g k+              else return g+        loop g')++generateRow :: Int -> IO [Monster]+generateRow w = do+  stdGen <- Random.getStdGen+  let monster = head $ Shuffle.shuffle' [defaultFloor, defaultFloor, defaultWall] 3 stdGen+  return $ replicate w monster++generateLevel :: Int -> Int -> IO [[Monster]]+generateLevel w h = replicateM h (generateRow w)++zombies :: Game -> Int+zombies g = width g `div` 10++generateMonsters :: Game -> [Monster] -> IO Game+generateMonsters g [] = return g+generateMonsters g (m:ms) = do+  let r = (loc . rogue) g++  x <- Random.getStdRandom $ Random.randomR (0, width g - 1)+  y <- Random.getStdRandom $ Random.randomR (0, height g - 1)++  if r == (x, y)+    then generateMonsters g (m:ms)+    else do+      let c = cellAt g (x, y)++      case symbol c of+        " " -> do+          let placedMonsters = monsters g+          let locs = map loc placedMonsters++          if (x, y) `elem` locs+            then generateMonsters g (m:ms)+            else do+              let m' = m { loc = (x, y) }+              let g' = g { monsters = m':placedMonsters }+              generateMonsters g' ms+        _ -> generateMonsters g (m:ms)++main :: IO ()+main = do+  startCharm++  w <- getWidth+  h <- getHeight++  -- Reserve space for messages+  let h' = h - messageSpace++  locX <- Random.getStdRandom $ Random.randomR (0, w - 1)+  locY <- Random.getStdRandom $ Random.randomR (0, h' - 1)++  lev <- generateLevel w h'+  let g = defaultGame {+        width = w,+        height = h',+        level = lev,+        rogue = defaultRogue {+          loc = (locX, locY)+          }+        }++  g' <- generateMonsters g (replicate (zombies g) defaultZombie)++  loop g'++  endCharm