Mercurial > repo
changeset 2138:bd08a41fcbe2
<oerjan> mv fueue.c emmental.hs src
| author | HackBot |
|---|---|
| date | Fri, 15 Feb 2013 07:18:08 +0000 |
| parents | a548af0c699d |
| children | 42dd5b1c999e |
| files | emmental.hs fueue.c src/emmental.hs src/fueue.c |
| diffstat | 4 files changed, 1081 insertions(+), 1081 deletions(-) [+] |
line wrap: on
line diff
--- a/emmental.hs Fri Feb 15 07:17:29 2013 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,431 +0,0 @@ --- --- emmental.hs --- Interpreter for the Emmental Programming Language --- Chris Pressey, Cat's Eye Technologies --- This work is in the public domain. See UNLICENSE for more information. --- --- Ørjan Johansen added main --- - - -import qualified Data.Map as Map -import qualified Data.Char as Char -import System.Environment (getArgs) - -main = do - args <- getArgs - case args of - "-d" : as -> debug =<< parse return as - _ -> emmental =<< parse return args - where - parse :: (String -> IO String) -> [String] -> IO String - parse _ ("-f":as) = parse readFile as - parse _ ("-e":as) = parse return as - parse op (a:as) = op a >>= (`fmap` parse op as) . (++) - parse _ [] = return "" - - ------------------------------------------------------------------------ --- ============================ Symbols ============================ -- ------------------------------------------------------------------------ - -type Symbol = Char - - ------------------------------------------------------------------------ --- ======================== Program States ========================= -- ------------------------------------------------------------------------ - -data State = State [Symbol] [Symbol] - deriving (Ord, Eq, Show) - -pop (State (head:tail) queue) = (head, State tail queue) -push (State list queue) sym = (State (sym:list) queue) - -popString (State (';':tail) queue) = ([], State tail queue) -popString (State (head:tail) queue) = - let - (string, state') = popString (State tail queue) - in - (string ++ [head], state') - -enqueue (State stack queue) symbol = State stack (symbol:queue) -dequeue (State stack queue) = - let - symbol = last queue - queue' = init queue - in - (symbol, State stack queue') - - ------------------------------------------------------------------------ --- ========================= Interpreters ========================== -- ------------------------------------------------------------------------ - -data Interpreter = Interp (Map.Map Symbol Operation) - -fetch (Interp map) sym = Map.findWithDefault (fitRegOp opNop) sym map -supplant (Interp map) sym op = (Interp (Map.insert sym op map)) - - ------------------------------------------------------------------------ --- ========================== Operations =========================== -- ------------------------------------------------------------------------ - -type Operation = State -> Interpreter -> IO (State, Interpreter) - -composeOps :: Operation -> Operation -> Operation - -composeOps op1 op2 = f where - f state interpreter = do - (state', interpreter') <- op1 state interpreter - op2 state' interpreter' - -createOp :: Interpreter -> [Symbol] -> Operation - -createOp interpreter [] = - (fitRegOp opNop) -createOp interpreter (head:tail) = - composeOps (fetch interpreter head) (createOp interpreter tail) - --- --- It's useful for us to express a lot of our operators as non-monadic --- functions that don't affect the interpreter. This is a little "adapter" --- function that lets us create monadic functions with the right signature --- from them. --- - -fitRegOp :: (State -> State) -> Operation - -fitRegOp regop = f where - f state interpreter = - let - state' = regop state - in - do return (state', interpreter) - - ------------------------------------------------------------- ---------------- The operations themselves. ----------------- ------------------------------------------------------------- - --- --- Redefine the meaning of the symbol on the stack with --- a mini-program also popped off the stack. --- - -opSupplant state interpreter = - let - (opSym, state') = pop state - (newOpDefn, state'') = popString state' - newOp = createOp interpreter newOpDefn - in - do return (state'', supplant interpreter opSym newOp) - --- --- Execute the symbol on the stack with the current interpreter. --- - -opEval state interpreter = - let - (opSym, state') = pop state - newOp = createOp interpreter [opSym] - in - newOp state' interpreter - --- --- I/O. --- - -opInput state interpreter = do - symbol <- getChar - do return (push state symbol, interpreter) - -opOutput state interpreter = - let - (symbol, state') = pop state - in do - putChar symbol - return (state', interpreter) - --- --- Primitive arithmetic. --- - -opAdd state = - let - (symA, state') = pop state - (symB, state'') = pop state' - in - push state'' (Char.chr (((Char.ord symB) + (Char.ord symA)) `mod` 256)) - -opSubtract state = - let - (symA, state') = pop state - (symB, state'') = pop state' - in - push state'' (Char.chr (((Char.ord symB) - (Char.ord symA)) `mod` 256)) - -discreteLog 0 = 8 -discreteLog 1 = 0 -discreteLog 2 = 1 -discreteLog n = (discreteLog (n `div` 2)) + 1 - -opDiscreteLog state = - let - (symbol, state') = pop state - in - push state' (Char.chr (discreteLog (Char.ord symbol))) - --- --- Stack manipulation. --- - --- --- Pop the top symbol of the stack, make a copy of it, push it back onto the --- stack, and enqueue the copy onto the queue. --- - -opEnqueueCopy state = - let - (sym, _) = pop state - in - enqueue state sym - --- --- Dequeue a symbol from the queue and push it onto the stack. --- - -opDequeue state = - let - (sym, state') = dequeue state - in - push state' sym - --- --- Duplicate the top symbol of the stack. --- - -opDuplicate state = - let - (symbol, _) = pop state - in - push state symbol - --- --- Miscellaneous operations. --- - -opNop state = - state - --- --- Parameterizable operations. --- - -opPushValue value state = - push state (Char.chr value) - -opAccumValue value state = - let - (sym, state') = pop state - value' = ((Char.ord sym) * 10) + value - in - push state' (Char.chr (value' `mod` 256)) - - ------------------------------------------------------------------------ --- ===================== Debugging Functions ======================= -- ------------------------------------------------------------------------ - -type Debugger = State -> Interpreter -> IO () - -debugNop s i = do - return () - -debugPrintState s i = do - putStr ((show s) ++ "\n") - return () - - ------------------------------------------------------------------------ --- ============================ Executor =========================== -- ------------------------------------------------------------------------ - -execute :: [Symbol] -> State -> Interpreter -> Debugger -> IO (State, Interpreter) - -execute [] state interpreter debugger = - return (state, interpreter) -execute (opSym:program') state interpreter debugger = - let - operation = fetch interpreter opSym - in do - (state', interpreter') <- operation state interpreter - debugger state' interpreter' - execute program' state' interpreter' debugger - - ------------------------------------------------------------------------ --- ====================== Top-Level Function ======================= -- ------------------------------------------------------------------------ - -initialInterpreter = Interp - (Map.fromList - [ - ('.', opOutput), - (',', opInput), - - ('#', fitRegOp (opPushValue 0)), - ('0', fitRegOp (opAccumValue 0)), - ('1', fitRegOp (opAccumValue 1)), - ('2', fitRegOp (opAccumValue 2)), - ('3', fitRegOp (opAccumValue 3)), - ('4', fitRegOp (opAccumValue 4)), - ('5', fitRegOp (opAccumValue 5)), - ('6', fitRegOp (opAccumValue 6)), - ('7', fitRegOp (opAccumValue 7)), - ('8', fitRegOp (opAccumValue 8)), - ('9', fitRegOp (opAccumValue 9)), - - ('+', fitRegOp opAdd), - ('-', fitRegOp opSubtract), - ('~', fitRegOp opDiscreteLog), - - ('^', fitRegOp opEnqueueCopy), - ('v', fitRegOp opDequeue), - (':', fitRegOp opDuplicate), - - ('!', opSupplant), - ('?', opEval), - - (';', fitRegOp (opPushValue (Char.ord ';'))) - ] - ) - -initialState = State [] [] - -emmental string = do - (state, interpreter) <- execute string initialState initialInterpreter debugNop - return state - -debug string = do - (state, interpreter) <- execute string initialState initialInterpreter debugPrintState - return state - - ------------------------------------------------------------------------ --- ========================== Test Cases =========================== -- ------------------------------------------------------------------------ - --- --- Drivers for test cases. 'demo' runs them straight, whereas 'test' --- uses the debugger. --- - -demo n = emmental (testProg n) - -test n = debug (testProg n) - --- --- Here we introduce a bit of a cheat, in order to make writing --- complex Emmental programs tolerable. You can still see the --- programs in their fully glory by executing "show (testProg n)". --- - -quote [] = [] -quote (symbol:rest) = "#" ++ (show (Char.ord symbol)) ++ (quote rest) - --- --- Add one and one. --- - -testProg 1 = "#1#1+" - --- --- Redefine & as "+". --- - -testProg 2 = ";#43#38!#1#1&" -- 59,43,38 ==> ";+&" - --- --- Redefine 0 as "9". --- - -testProg 3 = ";#57#48!#0" -- 59,57,48 ==> ";90" - --- --- Redefine 0 as "#48?". This results in an infinite loop when 0 is executed. --- - -testProg 4 = ";#35#52#56#63#48!0" -- 59,35,52,56,63,48 ==> ";#48?0" - --- --- Redefine $ as ".#36?". This results in a loop that pops symbols and --- and prints them, until the stack underflows, when $ is executed. --- - -testProg 5 = ";#46#35#51#54#63#36! #65#66#67#68#69$" - --- --- Duplicate the top stack element (assuming an empty queue.) --- This shows that the : operation is not strictly necessary --- (when you know the size of the queue.) --- - -testProg 6 = "#65^v" - --- --- Discard the top stack element (assuming more than one element --- on the stack, and an empty queue.) --- - -testProg 7 = "#33#123^v-+" - --- --- Swap the top two elements of the stack (assuming an empty queue.) --- - -testProg 8 = "#67#66#65^v^-+^^v^v^v-+^v-+^v-+vv" - --- --- Input a symbol. Report whether its ASCII value is even or odd. --- - -testProg 9 = (quote ";^v:") ++ "!" ++ -- : = dup - (quote ";#69.") ++ "#!" ++ -- NUL = print "E" - (quote ";#79.") ++ "#128!" ++ -- \128 = print "O" - (quote (";" ++ (take 127 [':',':'..]) ++ -- m = mul by 128 - (take 127 ['+','+'..]) ++ "m")) ++ "!" ++ - ",m?" - --- --- Input a symbol. Report whether it is M or not. --- - -testProg 10 = (quote ";#78.") ++ "#!" ++ -- NUL = print "N" - ";##1!" ++ -- SOH = same as NUL - ";##2!" ++ -- STX = same as NUL - ";##3!" ++ -- ETX = same as NUL - ";##4!" ++ -- EOT = same as NUL - ";##5!" ++ -- ENQ = same as NUL - ";##6!" ++ -- ACK = same as NUL - ";##7!" ++ -- BEL = same as NUL - (quote ";#89.") ++ "#8!" ++ -- BS = print "Y" - ",#77-~?" - --- --- Same as testProg 5, except stop printing when a NUL is --- encountered, instead of just underflowing the stack. --- - -testProg 11 = ";" ++ (quote ":~?$") ++ "!" ++ -- $ = dup & test - ";" ++ (quote ".$") ++ "#!" ++ -- NUL = print & repeat - ";#0#1!" ++ -- SOH = same as NUL - ";#0#2!" ++ -- STX = same as NUL - ";#0#3!" ++ -- ETX = same as NUL - ";#0#4!" ++ -- EOT = same as NUL - ";#0#5!" ++ -- ENQ = same as NUL - ";#0#6!" ++ -- ACK = same as NUL - ";#0#7!" ++ -- BEL = same as NUL - -- BS = stop (nop) - "#0" ++ (quote (reverse "Hello!")) ++ "$"
--- a/fueue.c Fri Feb 15 07:17:29 2013 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,650 +0,0 @@ -#include <stdio.h> -#include <stdlib.h> -#include <string.h> -#define TRUE 1 -#define FALSE 0 - -/* - * Fueue Interpreter in language C - * the esoteric programming language Fueue was designed in 2012 by Taneb. - * - * The following program was written by Stephan Kunne on august 29 2012. - * It is public domain; you are free to use it, copy it, distribute it, - * or do whatever you'd like with it. - * Credit and feedback are always appreciated ; you can email me at - * firstname dot name at gmail dot com with all your questions or remarks. - * - * Examples: - * - * ./fueuec '72 101 108 108 111 44 32 119 111 114 108 100 33 10 H' - * Hello, world! - * - * ./fueuec --print '):[):]' - * ):[):] - * :[):]) - * )[):][):] - * [):]): - * ):[):] - * (...and so on) - */ - -enum Typet -{ - NUM, FUN, BLOCK -}; - -typedef struct Queue Queue; -struct Queue -{ - int size; - struct Token *top; - struct Token *bottom; -}; - -union value -{ - int num; - char fun; - Queue block; -}; - -struct Token -{ - enum Typet what; - union value val; - struct Token *next; -}; - - -int is_empty(const Queue *q); // bool -void initQueue(Queue *q); // make it an empty queue -void push(struct Token *x, Queue *q); -struct Token* copyToken(const struct Token *x); -Queue copyQueue(const Queue *q); -void initToken(struct Token *x); -void pushnum(int num, Queue* q); // create NUM token and pushes it -void pushfun(char f, Queue* q); // create FUN token and pushes it -void pushblock(Queue newq, Queue* q); // create BLOCK token and pushes it -void deletetop(Queue* q); // suppose q not empty -void deleteQueue(Queue *q); -void sendback(Queue* q); // suppose q not empty, pop then push -struct Token* pop(Queue* q); // suppose q not empty -void append(Queue *q, const Queue *r); -int matchwhat(const Queue* q, const char s[]); // bool peek at first 2 "nn" "n" "." ".." "n." "b." "b" -void processFueue(Queue* q, int printmode); // the recursive function that does everything -Queue strtoqueue(const char s[], int *k); // transforms a string program into a queue program -void print_queue(const Queue *q); // prints a queue program -void error_empty(const char s[]); // raised by functions that "suppose q not empty" when q is empty - - -void processFueue(Queue* q, int printmode) -{ - int time = 0; // catching input - int i = 0; // to be used for input - int a = 0, b = 0; // to be used for some FUN - struct Token* p = NULL; // even more FUN - Queue newq; // having FUN with BLOCKs (specifically '(') - initQueue(&newq); // this is done at every iteration where newq is used, though - - while (TRUE) // stops thanks to a return; when 'H' is met - { - - if (printmode) - { - print_queue(q); - printf("\n"); - } - - if (time == q->size) // if time == q->size then input char and push ascii/unicode value - { - fflush(stdout); - i = getchar(); - pushnum(i, q); - time = 0; - } - - if (q->top->what == NUM) // q not empty because of the time != q->size requirement - { - // print char with ascii/unicode value q->top->val.num - printf("%c", (char) q->top->val.num); - fflush(stdout); - deletetop(q); - time = 0; - } - else if (q->top->what == FUN) - { - char op = q->top->val.fun; - deletetop(q); - switch (op) - { - case '+': - case '*': - case '/': - if (matchwhat(q, "nn")) - { - a = q->top->val.num; - deletetop(q); - b = q->top->val.num; - deletetop(q); - if (op == '+') - { pushnum(a+b, q); } - else if (op == '*') - { pushnum(a*b, q); } - else // op == '/' - { pushnum(a/b, q); } - time = 0; - } - else - { - pushfun(op, q); - time++; - } - break; - case '-': - case '%': - if (matchwhat(q, "n")) - { - a = q->top->val.num; - deletetop(q); - pushnum( ((op == '-')?(-a):(!a)) , q); - time = 0; - } - else - { - pushfun(op, q); - time++; - } - break; - case ':': - if (!is_empty(q)) - { - push(copyToken(q->top), q); // push copy - sendback(q); // push original - time = 0; - } - else - { - pushfun(op, q); - time++; - } - break; - case '~': - if (matchwhat(q, "..")) // if q has at least two items - { - p = pop(q); - sendback(q); - push(p, q); - time = 0; - } - else - { - pushfun(op, q); - time++; - } - break; - case '!': - if (is_empty(q)) - { - pushfun(op, q); - time++; - } - else - { - deletetop(q); - time = 0; - } - break; - case '$': - if (matchwhat(q, "n.")) - { - a = q->top->val.num; - deletetop(q); - for (; a > 0; a--) - { - push(copyToken(q->top), q); - } - - deletetop(q); - - time = 0; - } - else - { - pushfun(op, q); - time++; - } - break; - case '(': - if (is_empty(q)) - { - pushfun(op, q); - time++; - } - else - { - initQueue(&newq); - push(pop(q), &newq); - pushblock(newq, q); - time = 0; - // newq is the queue inside the block - } - break; - case '<': - if (matchwhat(q, "b.")) - { - sendback(q); - push(pop(q), &(q->bottom->val.block)); - time = 0; - } - else - { - pushfun(op, q); - time++; - } - break; - case ')': - if (matchwhat(q, "b")) - { - append(q, &(q->top->val.block)); - initQueue(&(q->top->val.block)); // mandatory since - deletetop(q); // deletetop does destroy the block it contains - time = 0; - } - else - { - pushfun(op, q); - time++; - } - break; - case 'H': - // don't forget to delete the remaining of the queue here, will you? - return; - default: - // raise an error - break; - } - } - else // if q->top->what == BLOCK - { - sendback(q); - time++; - } - } -} - - - -int main(int argc, char *argv[]) -{ - Queue q; - initQueue(&q); // q is empty now - char s[10000] = "72 101 108 108 111 44 32 119 111 114 108 100 33 10 H"; - int printmode = FALSE; // a debug mode that will print the fueue program at each step - int k = 0; - - switch (argc) - { - case 1: - break; - case 2: - if (strcmp(argv[1], "--print") == 0) - { - printmode = TRUE; - } - else - { - strncpy(s, argv[1], 10000); - } - break; - case 3: - strncpy(s, argv[2], 10000); - printmode = (strcmp(argv[1], "--print") == 0); - break; - default: - fprintf(stderr, "Error: %s received too many arguments. The Hello world program\n", argv[0]); - break; - } - - q = strtoqueue(s, &k); - - processFueue(&q, printmode); - return 0; -} - - -Queue strtoqueue(const char s[], int *k) // takes a fueue program as a string, and gives a queue -{ - // *k is loop counter - Queue q; // the queue to be returned - initQueue(&q); - int n = 0; // decimals (usually n * 10 + 0-9) - int intmode = FALSE; // bool "we're reading a number right now" - - if (*k == -1) - { - printf("FUEUE: UNMATCHED OPENING SQUARE BRACKET PROBABLY FORGOT A CLOSING SQUARE BRACKET\n"); - return q; - } - - while (s[*k] != '\0' && s[*k] != ']') - { - if (intmode && (s[*k] > '9' || s[*k] < '0')) // if intmode ends - { - pushnum(n, &q); - n = 0; - intmode = FALSE; - } - - switch (s[*k]) - { - case '+': - case '-': - case '*': - case '/': - case '%': - case ':': - case '~': - case '!': - case '$': - case '(': - case '<': - case ')': - case 'H': - pushfun(s[*k], &q); - (*k)++; - break; - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - n = n * 10 + (int) (s[*k] - '0'); - intmode = TRUE; - (*k)++; - break; - case '\n': - case '\t': - case ' ': // whitespace - (*k)++; - break; - case '[': - (*k)++; - pushblock(strtoqueue(s, k), &q); - (*k)++; - break; - default: - printf("FUEUE: UNKNOWN %c OP\n", s[*k]); - (*k)++; - break; - } - } - if (intmode) - { - pushnum(n, &q); - } - - if (s[*k] == '\0') - *k = -1; - return q; -} - -void print_queue(const Queue *q) -{ - struct Token *ptmp = q->top; - while (ptmp != NULL) - { - if (ptmp->what == NUM) - { - printf(" %d", ptmp->val.num); - } - else if (ptmp->what == FUN) - { - printf("%c", ptmp->val.fun); - } - else if (ptmp->what == BLOCK) - { - printf("["); - print_queue(&(ptmp->val.block)); - printf("]"); - } - else - { - printf("That's impossible...Neither num nor fun nor block...\n"); - } - ptmp = ptmp->next; - } -} - - - - -int is_empty(const Queue *q) // bool -{ - if (q->top == NULL) - { - if (q->bottom == NULL && q->size == 0) - { - return TRUE; - } - else - { - error_empty("is_empty"); - } - } - return FALSE; -} - -void initQueue(Queue *q) -{ - q->size = 0; - q->top = NULL; - q->bottom = NULL; -} - -void push(struct Token *x, Queue *q) -{ - if (is_empty(q)) - { - q->top = x; - } - else - { - q->bottom->next = x; - } - q->bottom = x; - q->size++; - x->next = NULL; // just in case -} - -Queue copyQueue(const Queue *q) -{ - Queue c; - struct Token* ptmp = q->top; - initQueue(&c); - - while (ptmp != NULL) - { - push(copyToken(ptmp), &c); - ptmp = ptmp->next; - } - - return c; -} - -void initToken(struct Token *x) -{ - x->what = NUM; - x->val.num = 0; - x->val.fun = '\0'; - initQueue(&(x->val.block)); - x->next = NULL; -} - -struct Token* copyToken(const struct Token *x) -{ - struct Token *c = malloc(sizeof(struct Token)); - c->what = x->what; - - switch (x->what) - { - case NUM: - case FUN: - c->val = x->val; - break; - case BLOCK: - c->val.block = copyQueue(&(x->val.block)); - break; - default: - fprintf(stderr, "Error: found a %d in my soup\n", x->what); - break; - } - - c->next = NULL; - return c; -} - -void pushnum(int num, Queue* q) -{ - struct Token *t = malloc(sizeof(struct Token)); - initToken(t); - t->what = NUM; - t->val.num = num; - - push(t, q); -} - -void pushfun(char f, Queue* q) -{ - struct Token *t = malloc(sizeof(struct Token)); - initToken(t); - t->what = FUN; - t->val.fun = f; - push(t, q); -} - -void pushblock(Queue newq, Queue* q) -{ - struct Token *t = malloc(sizeof(struct Token)); - initToken(t); - t->what = BLOCK; - t->val.block = newq; - push(t, q); -} - -void deletetop(Queue* q) // suppose q not empty -{ - if (is_empty(q)) - error_empty("deletetop"); - - struct Token *todelete = NULL; - - if (q->top->what == BLOCK) // has to free the Queue inside - { - deleteQueue(&(q->top->val.block)); - } - - if (q->top->next == NULL) - { - free(q->top); - q->top = NULL; - q->bottom = NULL; - } - else - { - todelete = q->top; - q->top = q->top->next; - free(todelete); - } - q->size--; -} - -void deleteQueue(Queue *q) -{ - while (!is_empty(q)) - { - deletetop(q); - } -} - -void sendback(Queue* q) // suppose q not empty, pop then push -{ - if (is_empty(q)) - error_empty("sendback"); - - q->bottom->next = q->top; - q->top = q->top->next; - q->bottom = q->bottom->next; - q->bottom->next = NULL; -} - -struct Token* pop(Queue* q) // suppose q not empty -{ - if (is_empty(q)) - error_empty("sendback"); - - struct Token* t = q->top; // note that t->next is equal to q->top->next now - q->top = q->top->next; - q->size--; - - return t; -} - -void append(Queue *q, const Queue *r) -{ - if (is_empty(q)) - { - q->top = r->top; - q->bottom = r->bottom; - } - else if (!is_empty(r)) - { - q->bottom->next = r->top; - q->bottom = r->bottom; - } - q->size += r->size; -} - -int matchwhat(const Queue* q, const char s[]) // bool "nn" "n" "." ".." "n." "b." "b" -{ - int itsok = TRUE; - if ((s[0] != '\0') && !(is_empty(q))) // if neither s nor q is empty - { - if (s[0] == 'n' && q->top->what != NUM) // if top should be num - itsok = FALSE; - if (s[0] == 'b' && q->top->what != BLOCK) // if top should be block - itsok = FALSE; - if (s[1] != '\0' && q->top->next == NULL) // if should have second element - { - itsok = FALSE; - } - else // so it indeed has a second element, or it doesn't need to have one - { - if (s[1] == 'n' && q->top->next->what != NUM) // second should be num - itsok = FALSE; - if (s[1] == 'b' && q->top->next->what != BLOCK) // second should be block - itsok = FALSE; - } - } - else - { - if (s[0] != '\0') // if s is not empty but q is - itsok = FALSE; - } - - // printf("matchwhat: %s\n", (itsok?"TRUE":"FALSE")); - return itsok; -} - -void error_empty(const char s[]) -{ - fprintf(stderr, "Error: queue was empty in %s\n", s); - exit(EXIT_FAILURE); -} - - -
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/emmental.hs Fri Feb 15 07:18:08 2013 +0000 @@ -0,0 +1,431 @@ +-- +-- emmental.hs +-- Interpreter for the Emmental Programming Language +-- Chris Pressey, Cat's Eye Technologies +-- This work is in the public domain. See UNLICENSE for more information. +-- +-- Ørjan Johansen added main +-- + + +import qualified Data.Map as Map +import qualified Data.Char as Char +import System.Environment (getArgs) + +main = do + args <- getArgs + case args of + "-d" : as -> debug =<< parse return as + _ -> emmental =<< parse return args + where + parse :: (String -> IO String) -> [String] -> IO String + parse _ ("-f":as) = parse readFile as + parse _ ("-e":as) = parse return as + parse op (a:as) = op a >>= (`fmap` parse op as) . (++) + parse _ [] = return "" + + +----------------------------------------------------------------------- +-- ============================ Symbols ============================ -- +----------------------------------------------------------------------- + +type Symbol = Char + + +----------------------------------------------------------------------- +-- ======================== Program States ========================= -- +----------------------------------------------------------------------- + +data State = State [Symbol] [Symbol] + deriving (Ord, Eq, Show) + +pop (State (head:tail) queue) = (head, State tail queue) +push (State list queue) sym = (State (sym:list) queue) + +popString (State (';':tail) queue) = ([], State tail queue) +popString (State (head:tail) queue) = + let + (string, state') = popString (State tail queue) + in + (string ++ [head], state') + +enqueue (State stack queue) symbol = State stack (symbol:queue) +dequeue (State stack queue) = + let + symbol = last queue + queue' = init queue + in + (symbol, State stack queue') + + +----------------------------------------------------------------------- +-- ========================= Interpreters ========================== -- +----------------------------------------------------------------------- + +data Interpreter = Interp (Map.Map Symbol Operation) + +fetch (Interp map) sym = Map.findWithDefault (fitRegOp opNop) sym map +supplant (Interp map) sym op = (Interp (Map.insert sym op map)) + + +----------------------------------------------------------------------- +-- ========================== Operations =========================== -- +----------------------------------------------------------------------- + +type Operation = State -> Interpreter -> IO (State, Interpreter) + +composeOps :: Operation -> Operation -> Operation + +composeOps op1 op2 = f where + f state interpreter = do + (state', interpreter') <- op1 state interpreter + op2 state' interpreter' + +createOp :: Interpreter -> [Symbol] -> Operation + +createOp interpreter [] = + (fitRegOp opNop) +createOp interpreter (head:tail) = + composeOps (fetch interpreter head) (createOp interpreter tail) + +-- +-- It's useful for us to express a lot of our operators as non-monadic +-- functions that don't affect the interpreter. This is a little "adapter" +-- function that lets us create monadic functions with the right signature +-- from them. +-- + +fitRegOp :: (State -> State) -> Operation + +fitRegOp regop = f where + f state interpreter = + let + state' = regop state + in + do return (state', interpreter) + + +------------------------------------------------------------ +--------------- The operations themselves. ----------------- +------------------------------------------------------------ + +-- +-- Redefine the meaning of the symbol on the stack with +-- a mini-program also popped off the stack. +-- + +opSupplant state interpreter = + let + (opSym, state') = pop state + (newOpDefn, state'') = popString state' + newOp = createOp interpreter newOpDefn + in + do return (state'', supplant interpreter opSym newOp) + +-- +-- Execute the symbol on the stack with the current interpreter. +-- + +opEval state interpreter = + let + (opSym, state') = pop state + newOp = createOp interpreter [opSym] + in + newOp state' interpreter + +-- +-- I/O. +-- + +opInput state interpreter = do + symbol <- getChar + do return (push state symbol, interpreter) + +opOutput state interpreter = + let + (symbol, state') = pop state + in do + putChar symbol + return (state', interpreter) + +-- +-- Primitive arithmetic. +-- + +opAdd state = + let + (symA, state') = pop state + (symB, state'') = pop state' + in + push state'' (Char.chr (((Char.ord symB) + (Char.ord symA)) `mod` 256)) + +opSubtract state = + let + (symA, state') = pop state + (symB, state'') = pop state' + in + push state'' (Char.chr (((Char.ord symB) - (Char.ord symA)) `mod` 256)) + +discreteLog 0 = 8 +discreteLog 1 = 0 +discreteLog 2 = 1 +discreteLog n = (discreteLog (n `div` 2)) + 1 + +opDiscreteLog state = + let + (symbol, state') = pop state + in + push state' (Char.chr (discreteLog (Char.ord symbol))) + +-- +-- Stack manipulation. +-- + +-- +-- Pop the top symbol of the stack, make a copy of it, push it back onto the +-- stack, and enqueue the copy onto the queue. +-- + +opEnqueueCopy state = + let + (sym, _) = pop state + in + enqueue state sym + +-- +-- Dequeue a symbol from the queue and push it onto the stack. +-- + +opDequeue state = + let + (sym, state') = dequeue state + in + push state' sym + +-- +-- Duplicate the top symbol of the stack. +-- + +opDuplicate state = + let + (symbol, _) = pop state + in + push state symbol + +-- +-- Miscellaneous operations. +-- + +opNop state = + state + +-- +-- Parameterizable operations. +-- + +opPushValue value state = + push state (Char.chr value) + +opAccumValue value state = + let + (sym, state') = pop state + value' = ((Char.ord sym) * 10) + value + in + push state' (Char.chr (value' `mod` 256)) + + +----------------------------------------------------------------------- +-- ===================== Debugging Functions ======================= -- +----------------------------------------------------------------------- + +type Debugger = State -> Interpreter -> IO () + +debugNop s i = do + return () + +debugPrintState s i = do + putStr ((show s) ++ "\n") + return () + + +----------------------------------------------------------------------- +-- ============================ Executor =========================== -- +----------------------------------------------------------------------- + +execute :: [Symbol] -> State -> Interpreter -> Debugger -> IO (State, Interpreter) + +execute [] state interpreter debugger = + return (state, interpreter) +execute (opSym:program') state interpreter debugger = + let + operation = fetch interpreter opSym + in do + (state', interpreter') <- operation state interpreter + debugger state' interpreter' + execute program' state' interpreter' debugger + + +----------------------------------------------------------------------- +-- ====================== Top-Level Function ======================= -- +----------------------------------------------------------------------- + +initialInterpreter = Interp + (Map.fromList + [ + ('.', opOutput), + (',', opInput), + + ('#', fitRegOp (opPushValue 0)), + ('0', fitRegOp (opAccumValue 0)), + ('1', fitRegOp (opAccumValue 1)), + ('2', fitRegOp (opAccumValue 2)), + ('3', fitRegOp (opAccumValue 3)), + ('4', fitRegOp (opAccumValue 4)), + ('5', fitRegOp (opAccumValue 5)), + ('6', fitRegOp (opAccumValue 6)), + ('7', fitRegOp (opAccumValue 7)), + ('8', fitRegOp (opAccumValue 8)), + ('9', fitRegOp (opAccumValue 9)), + + ('+', fitRegOp opAdd), + ('-', fitRegOp opSubtract), + ('~', fitRegOp opDiscreteLog), + + ('^', fitRegOp opEnqueueCopy), + ('v', fitRegOp opDequeue), + (':', fitRegOp opDuplicate), + + ('!', opSupplant), + ('?', opEval), + + (';', fitRegOp (opPushValue (Char.ord ';'))) + ] + ) + +initialState = State [] [] + +emmental string = do + (state, interpreter) <- execute string initialState initialInterpreter debugNop + return state + +debug string = do + (state, interpreter) <- execute string initialState initialInterpreter debugPrintState + return state + + +----------------------------------------------------------------------- +-- ========================== Test Cases =========================== -- +----------------------------------------------------------------------- + +-- +-- Drivers for test cases. 'demo' runs them straight, whereas 'test' +-- uses the debugger. +-- + +demo n = emmental (testProg n) + +test n = debug (testProg n) + +-- +-- Here we introduce a bit of a cheat, in order to make writing +-- complex Emmental programs tolerable. You can still see the +-- programs in their fully glory by executing "show (testProg n)". +-- + +quote [] = [] +quote (symbol:rest) = "#" ++ (show (Char.ord symbol)) ++ (quote rest) + +-- +-- Add one and one. +-- + +testProg 1 = "#1#1+" + +-- +-- Redefine & as "+". +-- + +testProg 2 = ";#43#38!#1#1&" -- 59,43,38 ==> ";+&" + +-- +-- Redefine 0 as "9". +-- + +testProg 3 = ";#57#48!#0" -- 59,57,48 ==> ";90" + +-- +-- Redefine 0 as "#48?". This results in an infinite loop when 0 is executed. +-- + +testProg 4 = ";#35#52#56#63#48!0" -- 59,35,52,56,63,48 ==> ";#48?0" + +-- +-- Redefine $ as ".#36?". This results in a loop that pops symbols and +-- and prints them, until the stack underflows, when $ is executed. +-- + +testProg 5 = ";#46#35#51#54#63#36! #65#66#67#68#69$" + +-- +-- Duplicate the top stack element (assuming an empty queue.) +-- This shows that the : operation is not strictly necessary +-- (when you know the size of the queue.) +-- + +testProg 6 = "#65^v" + +-- +-- Discard the top stack element (assuming more than one element +-- on the stack, and an empty queue.) +-- + +testProg 7 = "#33#123^v-+" + +-- +-- Swap the top two elements of the stack (assuming an empty queue.) +-- + +testProg 8 = "#67#66#65^v^-+^^v^v^v-+^v-+^v-+vv" + +-- +-- Input a symbol. Report whether its ASCII value is even or odd. +-- + +testProg 9 = (quote ";^v:") ++ "!" ++ -- : = dup + (quote ";#69.") ++ "#!" ++ -- NUL = print "E" + (quote ";#79.") ++ "#128!" ++ -- \128 = print "O" + (quote (";" ++ (take 127 [':',':'..]) ++ -- m = mul by 128 + (take 127 ['+','+'..]) ++ "m")) ++ "!" ++ + ",m?" + +-- +-- Input a symbol. Report whether it is M or not. +-- + +testProg 10 = (quote ";#78.") ++ "#!" ++ -- NUL = print "N" + ";##1!" ++ -- SOH = same as NUL + ";##2!" ++ -- STX = same as NUL + ";##3!" ++ -- ETX = same as NUL + ";##4!" ++ -- EOT = same as NUL + ";##5!" ++ -- ENQ = same as NUL + ";##6!" ++ -- ACK = same as NUL + ";##7!" ++ -- BEL = same as NUL + (quote ";#89.") ++ "#8!" ++ -- BS = print "Y" + ",#77-~?" + +-- +-- Same as testProg 5, except stop printing when a NUL is +-- encountered, instead of just underflowing the stack. +-- + +testProg 11 = ";" ++ (quote ":~?$") ++ "!" ++ -- $ = dup & test + ";" ++ (quote ".$") ++ "#!" ++ -- NUL = print & repeat + ";#0#1!" ++ -- SOH = same as NUL + ";#0#2!" ++ -- STX = same as NUL + ";#0#3!" ++ -- ETX = same as NUL + ";#0#4!" ++ -- EOT = same as NUL + ";#0#5!" ++ -- ENQ = same as NUL + ";#0#6!" ++ -- ACK = same as NUL + ";#0#7!" ++ -- BEL = same as NUL + -- BS = stop (nop) + "#0" ++ (quote (reverse "Hello!")) ++ "$"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/fueue.c Fri Feb 15 07:18:08 2013 +0000 @@ -0,0 +1,650 @@ +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#define TRUE 1 +#define FALSE 0 + +/* + * Fueue Interpreter in language C + * the esoteric programming language Fueue was designed in 2012 by Taneb. + * + * The following program was written by Stephan Kunne on august 29 2012. + * It is public domain; you are free to use it, copy it, distribute it, + * or do whatever you'd like with it. + * Credit and feedback are always appreciated ; you can email me at + * firstname dot name at gmail dot com with all your questions or remarks. + * + * Examples: + * + * ./fueuec '72 101 108 108 111 44 32 119 111 114 108 100 33 10 H' + * Hello, world! + * + * ./fueuec --print '):[):]' + * ):[):] + * :[):]) + * )[):][):] + * [):]): + * ):[):] + * (...and so on) + */ + +enum Typet +{ + NUM, FUN, BLOCK +}; + +typedef struct Queue Queue; +struct Queue +{ + int size; + struct Token *top; + struct Token *bottom; +}; + +union value +{ + int num; + char fun; + Queue block; +}; + +struct Token +{ + enum Typet what; + union value val; + struct Token *next; +}; + + +int is_empty(const Queue *q); // bool +void initQueue(Queue *q); // make it an empty queue +void push(struct Token *x, Queue *q); +struct Token* copyToken(const struct Token *x); +Queue copyQueue(const Queue *q); +void initToken(struct Token *x); +void pushnum(int num, Queue* q); // create NUM token and pushes it +void pushfun(char f, Queue* q); // create FUN token and pushes it +void pushblock(Queue newq, Queue* q); // create BLOCK token and pushes it +void deletetop(Queue* q); // suppose q not empty +void deleteQueue(Queue *q); +void sendback(Queue* q); // suppose q not empty, pop then push +struct Token* pop(Queue* q); // suppose q not empty +void append(Queue *q, const Queue *r); +int matchwhat(const Queue* q, const char s[]); // bool peek at first 2 "nn" "n" "." ".." "n." "b." "b" +void processFueue(Queue* q, int printmode); // the recursive function that does everything +Queue strtoqueue(const char s[], int *k); // transforms a string program into a queue program +void print_queue(const Queue *q); // prints a queue program +void error_empty(const char s[]); // raised by functions that "suppose q not empty" when q is empty + + +void processFueue(Queue* q, int printmode) +{ + int time = 0; // catching input + int i = 0; // to be used for input + int a = 0, b = 0; // to be used for some FUN + struct Token* p = NULL; // even more FUN + Queue newq; // having FUN with BLOCKs (specifically '(') + initQueue(&newq); // this is done at every iteration where newq is used, though + + while (TRUE) // stops thanks to a return; when 'H' is met + { + + if (printmode) + { + print_queue(q); + printf("\n"); + } + + if (time == q->size) // if time == q->size then input char and push ascii/unicode value + { + fflush(stdout); + i = getchar(); + pushnum(i, q); + time = 0; + } + + if (q->top->what == NUM) // q not empty because of the time != q->size requirement + { + // print char with ascii/unicode value q->top->val.num + printf("%c", (char) q->top->val.num); + fflush(stdout); + deletetop(q); + time = 0; + } + else if (q->top->what == FUN) + { + char op = q->top->val.fun; + deletetop(q); + switch (op) + { + case '+': + case '*': + case '/': + if (matchwhat(q, "nn")) + { + a = q->top->val.num; + deletetop(q); + b = q->top->val.num; + deletetop(q); + if (op == '+') + { pushnum(a+b, q); } + else if (op == '*') + { pushnum(a*b, q); } + else // op == '/' + { pushnum(a/b, q); } + time = 0; + } + else + { + pushfun(op, q); + time++; + } + break; + case '-': + case '%': + if (matchwhat(q, "n")) + { + a = q->top->val.num; + deletetop(q); + pushnum( ((op == '-')?(-a):(!a)) , q); + time = 0; + } + else + { + pushfun(op, q); + time++; + } + break; + case ':': + if (!is_empty(q)) + { + push(copyToken(q->top), q); // push copy + sendback(q); // push original + time = 0; + } + else + { + pushfun(op, q); + time++; + } + break; + case '~': + if (matchwhat(q, "..")) // if q has at least two items + { + p = pop(q); + sendback(q); + push(p, q); + time = 0; + } + else + { + pushfun(op, q); + time++; + } + break; + case '!': + if (is_empty(q)) + { + pushfun(op, q); + time++; + } + else + { + deletetop(q); + time = 0; + } + break; + case '$': + if (matchwhat(q, "n.")) + { + a = q->top->val.num; + deletetop(q); + for (; a > 0; a--) + { + push(copyToken(q->top), q); + } + + deletetop(q); + + time = 0; + } + else + { + pushfun(op, q); + time++; + } + break; + case '(': + if (is_empty(q)) + { + pushfun(op, q); + time++; + } + else + { + initQueue(&newq); + push(pop(q), &newq); + pushblock(newq, q); + time = 0; + // newq is the queue inside the block + } + break; + case '<': + if (matchwhat(q, "b.")) + { + sendback(q); + push(pop(q), &(q->bottom->val.block)); + time = 0; + } + else + { + pushfun(op, q); + time++; + } + break; + case ')': + if (matchwhat(q, "b")) + { + append(q, &(q->top->val.block)); + initQueue(&(q->top->val.block)); // mandatory since + deletetop(q); // deletetop does destroy the block it contains + time = 0; + } + else + { + pushfun(op, q); + time++; + } + break; + case 'H': + // don't forget to delete the remaining of the queue here, will you? + return; + default: + // raise an error + break; + } + } + else // if q->top->what == BLOCK + { + sendback(q); + time++; + } + } +} + + + +int main(int argc, char *argv[]) +{ + Queue q; + initQueue(&q); // q is empty now + char s[10000] = "72 101 108 108 111 44 32 119 111 114 108 100 33 10 H"; + int printmode = FALSE; // a debug mode that will print the fueue program at each step + int k = 0; + + switch (argc) + { + case 1: + break; + case 2: + if (strcmp(argv[1], "--print") == 0) + { + printmode = TRUE; + } + else + { + strncpy(s, argv[1], 10000); + } + break; + case 3: + strncpy(s, argv[2], 10000); + printmode = (strcmp(argv[1], "--print") == 0); + break; + default: + fprintf(stderr, "Error: %s received too many arguments. The Hello world program\n", argv[0]); + break; + } + + q = strtoqueue(s, &k); + + processFueue(&q, printmode); + return 0; +} + + +Queue strtoqueue(const char s[], int *k) // takes a fueue program as a string, and gives a queue +{ + // *k is loop counter + Queue q; // the queue to be returned + initQueue(&q); + int n = 0; // decimals (usually n * 10 + 0-9) + int intmode = FALSE; // bool "we're reading a number right now" + + if (*k == -1) + { + printf("FUEUE: UNMATCHED OPENING SQUARE BRACKET PROBABLY FORGOT A CLOSING SQUARE BRACKET\n"); + return q; + } + + while (s[*k] != '\0' && s[*k] != ']') + { + if (intmode && (s[*k] > '9' || s[*k] < '0')) // if intmode ends + { + pushnum(n, &q); + n = 0; + intmode = FALSE; + } + + switch (s[*k]) + { + case '+': + case '-': + case '*': + case '/': + case '%': + case ':': + case '~': + case '!': + case '$': + case '(': + case '<': + case ')': + case 'H': + pushfun(s[*k], &q); + (*k)++; + break; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + n = n * 10 + (int) (s[*k] - '0'); + intmode = TRUE; + (*k)++; + break; + case '\n': + case '\t': + case ' ': // whitespace + (*k)++; + break; + case '[': + (*k)++; + pushblock(strtoqueue(s, k), &q); + (*k)++; + break; + default: + printf("FUEUE: UNKNOWN %c OP\n", s[*k]); + (*k)++; + break; + } + } + if (intmode) + { + pushnum(n, &q); + } + + if (s[*k] == '\0') + *k = -1; + return q; +} + +void print_queue(const Queue *q) +{ + struct Token *ptmp = q->top; + while (ptmp != NULL) + { + if (ptmp->what == NUM) + { + printf(" %d", ptmp->val.num); + } + else if (ptmp->what == FUN) + { + printf("%c", ptmp->val.fun); + } + else if (ptmp->what == BLOCK) + { + printf("["); + print_queue(&(ptmp->val.block)); + printf("]"); + } + else + { + printf("That's impossible...Neither num nor fun nor block...\n"); + } + ptmp = ptmp->next; + } +} + + + + +int is_empty(const Queue *q) // bool +{ + if (q->top == NULL) + { + if (q->bottom == NULL && q->size == 0) + { + return TRUE; + } + else + { + error_empty("is_empty"); + } + } + return FALSE; +} + +void initQueue(Queue *q) +{ + q->size = 0; + q->top = NULL; + q->bottom = NULL; +} + +void push(struct Token *x, Queue *q) +{ + if (is_empty(q)) + { + q->top = x; + } + else + { + q->bottom->next = x; + } + q->bottom = x; + q->size++; + x->next = NULL; // just in case +} + +Queue copyQueue(const Queue *q) +{ + Queue c; + struct Token* ptmp = q->top; + initQueue(&c); + + while (ptmp != NULL) + { + push(copyToken(ptmp), &c); + ptmp = ptmp->next; + } + + return c; +} + +void initToken(struct Token *x) +{ + x->what = NUM; + x->val.num = 0; + x->val.fun = '\0'; + initQueue(&(x->val.block)); + x->next = NULL; +} + +struct Token* copyToken(const struct Token *x) +{ + struct Token *c = malloc(sizeof(struct Token)); + c->what = x->what; + + switch (x->what) + { + case NUM: + case FUN: + c->val = x->val; + break; + case BLOCK: + c->val.block = copyQueue(&(x->val.block)); + break; + default: + fprintf(stderr, "Error: found a %d in my soup\n", x->what); + break; + } + + c->next = NULL; + return c; +} + +void pushnum(int num, Queue* q) +{ + struct Token *t = malloc(sizeof(struct Token)); + initToken(t); + t->what = NUM; + t->val.num = num; + + push(t, q); +} + +void pushfun(char f, Queue* q) +{ + struct Token *t = malloc(sizeof(struct Token)); + initToken(t); + t->what = FUN; + t->val.fun = f; + push(t, q); +} + +void pushblock(Queue newq, Queue* q) +{ + struct Token *t = malloc(sizeof(struct Token)); + initToken(t); + t->what = BLOCK; + t->val.block = newq; + push(t, q); +} + +void deletetop(Queue* q) // suppose q not empty +{ + if (is_empty(q)) + error_empty("deletetop"); + + struct Token *todelete = NULL; + + if (q->top->what == BLOCK) // has to free the Queue inside + { + deleteQueue(&(q->top->val.block)); + } + + if (q->top->next == NULL) + { + free(q->top); + q->top = NULL; + q->bottom = NULL; + } + else + { + todelete = q->top; + q->top = q->top->next; + free(todelete); + } + q->size--; +} + +void deleteQueue(Queue *q) +{ + while (!is_empty(q)) + { + deletetop(q); + } +} + +void sendback(Queue* q) // suppose q not empty, pop then push +{ + if (is_empty(q)) + error_empty("sendback"); + + q->bottom->next = q->top; + q->top = q->top->next; + q->bottom = q->bottom->next; + q->bottom->next = NULL; +} + +struct Token* pop(Queue* q) // suppose q not empty +{ + if (is_empty(q)) + error_empty("sendback"); + + struct Token* t = q->top; // note that t->next is equal to q->top->next now + q->top = q->top->next; + q->size--; + + return t; +} + +void append(Queue *q, const Queue *r) +{ + if (is_empty(q)) + { + q->top = r->top; + q->bottom = r->bottom; + } + else if (!is_empty(r)) + { + q->bottom->next = r->top; + q->bottom = r->bottom; + } + q->size += r->size; +} + +int matchwhat(const Queue* q, const char s[]) // bool "nn" "n" "." ".." "n." "b." "b" +{ + int itsok = TRUE; + if ((s[0] != '\0') && !(is_empty(q))) // if neither s nor q is empty + { + if (s[0] == 'n' && q->top->what != NUM) // if top should be num + itsok = FALSE; + if (s[0] == 'b' && q->top->what != BLOCK) // if top should be block + itsok = FALSE; + if (s[1] != '\0' && q->top->next == NULL) // if should have second element + { + itsok = FALSE; + } + else // so it indeed has a second element, or it doesn't need to have one + { + if (s[1] == 'n' && q->top->next->what != NUM) // second should be num + itsok = FALSE; + if (s[1] == 'b' && q->top->next->what != BLOCK) // second should be block + itsok = FALSE; + } + } + else + { + if (s[0] != '\0') // if s is not empty but q is + itsok = FALSE; + } + + // printf("matchwhat: %s\n", (itsok?"TRUE":"FALSE")); + return itsok; +} + +void error_empty(const char s[]) +{ + fprintf(stderr, "Error: queue was empty in %s\n", s); + exit(EXIT_FAILURE); +} + + +