sforman
/
Thun
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Format.

This commit is contained in:
sforman 2023-07-30 07:47:26 -07:00
parent 9963a73322
commit 64d9bb75a4
1 changed files with 541 additions and 284 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

629
implementations/Elm/src/Joy.elm
View File

@ -1,9 +1,9 @@
module Joy exposing (doit, JoyDict, initialize)
module Joy exposing (JoyDict, doit, initialize)
import Bitwise
import Dict exposing (Dict, get, insert)
import Result exposing (andThen)
import String exposing (replace, words, lines)
import String exposing (lines, replace, words)
type JoyType
@ -13,9 +13,13 @@ type JoyType
| JoyTrue
| JoyFalse
type alias JList = List JoyType
type alias JoyDict = Dict String JList
type alias JList =
List JoyType
type alias JoyDict =
Dict String JList
joy : JList -> JList -> JoyDict -> Result String ( JList, JoyDict )
@ -23,12 +27,17 @@ joy stack expression dict =
case expression of
[] ->
Ok ( stack, dict )
term :: rest_of_expression ->
case term of
JoySymbol symbol ->
case joy_eval symbol stack rest_of_expression dict of
Err msg -> Err msg
Ok (s, e, dict0) -> joy s e dict0
Err msg ->
Err msg
Ok ( s, e, dict0 ) ->
joy s e dict0
_ ->
joy (term :: stack) rest_of_expression dict
@ -37,8 +46,10 @@ joy_eval : String -> JList -> JList -> JoyDict -> Result String (JList, JList, J
joy_eval symbol stack expression dict =
if symbol == "" then
Ok ( stack, expression, dict )
else if symbol == "inscribe" then
joy_inscribe stack expression dict
else
case joy_function_eval symbol stack expression of
Err msg ->
@ -47,301 +58,470 @@ joy_eval symbol stack expression dict =
case get symbol dict of
Just definition ->
Ok ( stack, definition ++ expression, dict )
Nothing ->
Err ("Unknown word: " ++ symbol)
else
Err msg
Ok (stack0, expression0) -> Ok (stack0, expression0, dict)
Ok ( stack0, expression0 ) ->
Ok ( stack0, expression0, dict )
joy_function_eval symbol stack expression =
case symbol of
"branch" ->
joy_branch stack expression
"branch" -> joy_branch stack expression
"i" -> joy_i stack expression
"dip" -> joy_dip stack expression
"loop" -> joy_loop stack expression
"i" ->
joy_i stack expression
"+" -> joy_binary_math_op (+) stack expression
"-" -> joy_binary_math_op (-) stack expression
"*" -> joy_binary_math_op (*) stack expression
"/" -> joy_binary_math_op (//) stack expression
"%" -> joy_binary_math_op (swap_args remainderBy) stack expression
"dip" ->
joy_dip stack expression
"add" -> joy_binary_math_op (+) stack expression
"sub" -> joy_binary_math_op (-) stack expression
"mul" -> joy_binary_math_op (*) stack expression
"div" -> joy_binary_math_op (//) stack expression
"mod" -> joy_binary_math_op (swap_args remainderBy) stack expression
"loop" ->
joy_loop stack expression
"<" -> joy_comparison_op (<) stack expression
">" -> joy_comparison_op (>) stack expression
"<=" -> joy_comparison_op (<=) stack expression
">=" -> joy_comparison_op (>=) stack expression
"<>" -> joy_comparison_op (/=) stack expression
"!=" -> joy_comparison_op (/=) stack expression
"=" -> joy_comparison_op (==) stack expression
"+" ->
joy_binary_math_op (+) stack expression
"and" -> joy_binary_math_op (Bitwise.and) stack expression
"or" -> joy_binary_math_op (Bitwise.or) stack expression
"xor" -> joy_binary_math_op (Bitwise.xor) stack expression
"lshift" -> joy_binary_math_op (swap_args Bitwise.shiftLeftBy) stack expression
"<<" -> joy_binary_math_op (swap_args Bitwise.shiftLeftBy) stack expression
"rshift" -> joy_binary_math_op (swap_args Bitwise.shiftRightBy) stack expression
">>" -> joy_binary_math_op (swap_args Bitwise.shiftRightBy) stack expression
"-" ->
joy_binary_math_op (-) stack expression
"/\\" -> joy_logical_op (&&) stack expression
"\\/" -> joy_logical_op (||) stack expression
"_\\/_" -> joy_logical_op (xor) stack expression
"*" ->
joy_binary_math_op (*) stack expression
"clear" -> Ok ([], expression)
"concat" -> joy_concat stack expression
"cons" -> joy_cons stack expression
"dup" -> joy_dup stack expression
"first" -> joy_first stack expression
"pop" -> joy_pop stack expression
"rest" -> joy_rest stack expression
"stack" -> joy_stack stack expression
"swaack" -> joy_swaack stack expression
"swap" -> joy_swap stack expression
"truthy" -> joy_truthy stack expression
"bool" -> joy_truthy stack expression
"/" ->
joy_binary_math_op (//) stack expression
_ -> Err ("Unknown word.")
"%" ->
joy_binary_math_op (swap_args remainderBy) stack expression
"add" ->
joy_binary_math_op (+) stack expression
"sub" ->
joy_binary_math_op (-) stack expression
"mul" ->
joy_binary_math_op (*) stack expression
"div" ->
joy_binary_math_op (//) stack expression
"mod" ->
joy_binary_math_op (swap_args remainderBy) stack expression
"<" ->
joy_comparison_op (<) stack expression
">" ->
joy_comparison_op (>) stack expression
"<=" ->
joy_comparison_op (<=) stack expression
">=" ->
joy_comparison_op (>=) stack expression
"<>" ->
joy_comparison_op (/=) stack expression
"!=" ->
joy_comparison_op (/=) stack expression
"=" ->
joy_comparison_op (==) stack expression
"and" ->
joy_binary_math_op Bitwise.and stack expression
"or" ->
joy_binary_math_op Bitwise.or stack expression
"xor" ->
joy_binary_math_op Bitwise.xor stack expression
"lshift" ->
joy_binary_math_op (swap_args Bitwise.shiftLeftBy) stack expression
"<<" ->
joy_binary_math_op (swap_args Bitwise.shiftLeftBy) stack expression
"rshift" ->
joy_binary_math_op (swap_args Bitwise.shiftRightBy) stack expression
">>" ->
joy_binary_math_op (swap_args Bitwise.shiftRightBy) stack expression
"/\\" ->
joy_logical_op (&&) stack expression
"\\/" ->
joy_logical_op (||) stack expression
"_\\/_" ->
joy_logical_op xor stack expression
"clear" ->
Ok ( [], expression )
"concat" ->
joy_concat stack expression
"cons" ->
joy_cons stack expression
"dup" ->
joy_dup stack expression
"first" ->
joy_first stack expression
"pop" ->
joy_pop stack expression
"rest" ->
joy_rest stack expression
"stack" ->
joy_stack stack expression
"swaack" ->
joy_swaack stack expression
"swap" ->
joy_swap stack expression
"truthy" ->
joy_truthy stack expression
"bool" ->
joy_truthy stack expression
_ ->
Err "Unknown word."
joy_inscribe : JList -> JList -> JoyDict -> Result String ( JList, JList, JoyDict )
joy_inscribe stack expression dict =
case pop_list(stack) of
case pop_list stack of
Ok ( def, s0 ) ->
case def of
[] -> Err "Empty definition."
[] ->
Err "Empty definition."
sym :: body ->
-- check that name is a symbol
case sym of
JoySymbol name ->
Ok (s0, expression, (insert name body dict))
Ok ( s0, expression, insert name body dict )
_ ->
Err "Def name isn't symbol."
Err msg -> Err msg
Err msg ->
Err msg
joy_branch : JList -> JList -> Result String ( JList, JList )
joy_branch stack expression =
case pop_list(stack) of
case pop_list stack of
Ok ( true_body, s0 ) ->
case pop_list(s0) of
case pop_list s0 of
Ok ( false_body, s1 ) ->
case pop_bool(s1) of
case pop_bool s1 of
Ok ( flag, s2 ) ->
if flag then
Ok ( s2, true_body ++ expression )
else
Ok ( s2, false_body ++ expression )
Err msg -> Err msg
Err msg -> Err msg
Err msg -> Err msg
Err msg ->
Err msg
Err msg ->
Err msg
Err msg ->
Err msg
joy_i : JList -> JList -> Result String ( JList, JList )
joy_i stack expression =
case pop_list(stack) of
Ok (a, s0) -> Ok (s0, a ++ expression)
Err msg -> Err msg
case pop_list stack of
Ok ( a, s0 ) ->
Ok ( s0, a ++ expression )
Err msg ->
Err msg
joy_dip : JList -> JList -> Result String ( JList, JList )
joy_dip stack expression =
case pop_list(stack) of
case pop_list stack of
Ok ( quoted_expression, s0 ) ->
case pop_any(s0) of
Ok (x, s1) -> Ok (s1, quoted_expression ++ (x :: expression))
Err msg -> Err msg
Err msg -> Err msg
case pop_any s0 of
Ok ( x, s1 ) ->
Ok ( s1, quoted_expression ++ (x :: expression) )
Err msg ->
Err msg
Err msg ->
Err msg
joy_loop : JList -> JList -> Result String ( JList, JList )
joy_loop stack expression =
case pop_list(stack) of
case pop_list stack of
Ok ( loop_body, s0 ) ->
case pop_bool(s0) of
case pop_bool s0 of
Ok ( flag, s1 ) ->
if flag then
Ok (s1, loop_body ++ ((JoyList loop_body) :: (JoySymbol "loop") :: expression))
Ok ( s1, loop_body ++ (JoyList loop_body :: JoySymbol "loop" :: expression) )
else
Ok ( s1, expression )
Err msg -> Err msg
Err msg -> Err msg
Err msg ->
Err msg
Err msg ->
Err msg
joy_binary_math_op : (Int -> Int -> Int) -> JList -> JList -> Result String ( JList, JList )
joy_binary_math_op op stack expression =
case pop_int(stack) of
case pop_int stack of
Ok ( a, s0 ) ->
case pop_int(s0) of
case pop_int s0 of
Ok ( b, s1 ) ->
Ok ((push_int (op b a) s1), expression)
Err msg -> Err msg
Err msg -> Err msg
Ok ( push_int (op b a) s1, expression )
Err msg ->
Err msg
Err msg ->
Err msg
swap_args : (Int -> Int -> Int) -> (Int -> Int -> Int)
swap_args op = (\a b -> op b a)
swap_args op =
\a b -> op b a
joy_comparison_op : (Int -> Int -> Bool) -> JList -> JList -> Result String ( JList, JList )
joy_comparison_op op stack expression =
case pop_int(stack) of
case pop_int stack of
Ok ( a, s0 ) ->
case pop_int(s0) of
case pop_int s0 of
Ok ( b, s1 ) ->
Ok ((push_bool (op b a) s1), expression)
Err msg -> Err msg
Err msg -> Err msg
Ok ( push_bool (op b a) s1, expression )
Err msg ->
Err msg
Err msg ->
Err msg
joy_logical_op : (Bool -> Bool -> Bool) -> JList -> JList -> Result String ( JList, JList )
joy_logical_op op stack expression =
case pop_bool(stack) of
case pop_bool stack of
Ok ( a, s0 ) ->
case pop_bool(s0) of
case pop_bool s0 of
Ok ( b, s1 ) ->
Ok ((push_bool (op b a) s1), expression)
Err msg -> Err msg
Err msg -> Err msg
Ok ( push_bool (op b a) s1, expression )
Err msg ->
Err msg
Err msg ->
Err msg
joy_concat : JList -> JList -> Result String ( JList, JList )
joy_concat stack expression =
case pop_list(stack) of
case pop_list stack of
Ok ( a, s0 ) ->
case pop_list(s0) of
case pop_list s0 of
Ok ( b, s1 ) ->
Ok ((push_list (b ++ a) s1), expression)
Err msg -> Err msg
Err msg -> Err msg
Ok ( push_list (b ++ a) s1, expression )
Err msg ->
Err msg
Err msg ->
Err msg
joy_cons : JList -> JList -> Result String ( JList, JList )
joy_cons stack expression =
case pop_list(stack) of
case pop_list stack of
Ok ( a, s0 ) ->
case pop_any(s0) of
case pop_any s0 of
Ok ( b, s1 ) ->
Ok ((push_list (b :: a) s1), expression)
Err msg -> Err msg
Err msg -> Err msg
Ok ( push_list (b :: a) s1, expression )
Err msg ->
Err msg
Err msg ->
Err msg
joy_dup : JList -> JList -> Result String ( JList, JList )
joy_dup stack expression =
case pop_any(stack) of
Ok (a, s0) -> Ok ((a :: stack), expression)
Err msg -> Err msg
case pop_any stack of
Ok ( a, s0 ) ->
Ok ( a :: stack, expression )
Err msg ->
Err msg
joy_first : JList -> JList -> Result String ( JList, JList )
joy_first stack expression =
case pop_list(stack) of
case pop_list stack of
Ok ( a, s0 ) ->
case pop_any(a) of
Ok (b, _) -> Ok ((push_any b s0), expression)
Err _ -> Err "Cannot take first of empty list."
Err msg -> Err msg
case pop_any a of
Ok ( b, _ ) ->
Ok ( push_any b s0, expression )
Err _ ->
Err "Cannot take first of empty list."
Err msg ->
Err msg
joy_pop : JList -> JList -> Result String ( JList, JList )
joy_pop stack expression =
case pop_any(stack) of
Ok (_, s0) -> Ok (s0, expression)
Err msg -> Err msg
case pop_any stack of
Ok ( _, s0 ) ->
Ok ( s0, expression )
Err msg ->
Err msg
joy_rest : JList -> JList -> Result String ( JList, JList )
joy_rest stack expression =
case pop_list(stack) of
case pop_list stack of
Ok ( a, s0 ) ->
case pop_any(a) of
Ok (_, el) -> Ok ((push_list el s0), expression)
Err _ -> Err "Cannot take rest of empty list."
Err msg -> Err msg
case pop_any a of
Ok ( _, el ) ->
Ok ( push_list el s0, expression )
Err _ ->
Err "Cannot take rest of empty list."
Err msg ->
Err msg
joy_stack : JList -> JList -> Result String ( JList, JList )
joy_stack stack expression =
Ok ((push_list stack stack), expression)
Ok ( push_list stack stack, expression )
joy_swaack : JList -> JList -> Result String ( JList, JList )
joy_swaack stack expression =
case pop_list(stack) of
Ok (s, s0) -> Ok ((push_list s0 s), expression)
Err msg -> Err msg
case pop_list stack of
Ok ( s, s0 ) ->
Ok ( push_list s0 s, expression )
Err msg ->
Err msg
joy_swap : JList -> JList -> Result String ( JList, JList )
joy_swap stack expression =
case pop_any(stack) of
case pop_any stack of
Ok ( a, s0 ) ->
case pop_any(s0) of
Ok (b, s1) -> Ok ((b :: a :: s1), expression)
Err msg -> Err msg
Err msg -> Err msg
case pop_any s0 of
Ok ( b, s1 ) ->
Ok ( b :: a :: s1, expression )
Err msg ->
Err msg
Err msg ->
Err msg
joy_truthy : JList -> JList -> Result String ( JList, JList )
joy_truthy stack expression =
case pop_any(stack) of
case pop_any stack of
Ok ( a, s0 ) ->
case a of
JoyTrue -> Ok (stack, expression)
JoyFalse -> Ok (stack, expression)
JoyTrue ->
Ok ( stack, expression )
JoyFalse ->
Ok ( stack, expression )
JoyInt i ->
if 0 == i then
Ok ( JoyFalse :: s0, expression )
else
Ok ( JoyTrue :: s0, expression )
JoyList el ->
if [] == el then
Ok ( JoyFalse :: s0, expression )
else
Ok ( JoyTrue :: s0, expression )
JoySymbol _ ->
Err "Cannot Boolify."
Err msg -> Err msg
Err msg ->
Err msg
push_bool : Bool -> JList -> JList
push_bool flag stack =
if flag then
JoyTrue :: stack
else
JoyFalse :: stack
push_int : Int -> JList -> JList
push_int i stack = (JoyInt i) :: stack
push_int i stack =
JoyInt i :: stack
push_list : JList -> JList -> JList
push_list el stack = (JoyList el) :: stack
push_list el stack =
JoyList el :: stack
push_any : JoyType -> JList -> JList
push_any j stack = j :: stack
push_any j stack =
j :: stack
pop_int : JList -> Result String ( Int, JList )
pop_int stack = pop_any stack |> andThen isnt_int
pop_int stack =
pop_any stack |> andThen isnt_int
pop_list : JList -> Result String ( JList, JList )
pop_list stack = pop_any stack |> andThen isnt_list
pop_list stack =
pop_any stack |> andThen isnt_list
pop_bool : JList -> Result String ( Bool, JList )
pop_bool stack = pop_any stack |> andThen isnt_bool
pop_bool stack =
pop_any stack |> andThen isnt_bool
pop_any : JList -> Result String ( JoyType, JList )
@ -349,6 +529,7 @@ pop_any stack =
case stack of
[] ->
Err "Not enough values on Stack"
item :: rest ->
Ok ( item, rest )
@ -358,6 +539,7 @@ isnt_int (item, stack) =
case item of
JoyInt i ->
Ok ( i, stack )
_ ->
Err "Not an integer."
@ -367,6 +549,7 @@ isnt_list (item, stack) =
case item of
JoyList el ->
Ok ( el, stack )
_ ->
Err "Not a list."
@ -374,101 +557,163 @@ isnt_list (item, stack) =
isnt_bool : ( JoyType, JList ) -> Result String ( Bool, JList )
isnt_bool ( item, stack ) =
case item of
JoyTrue -> Ok (True, stack)
JoyFalse -> Ok (False, stack)
_ -> Err "Not a Boolean value."
JoyTrue ->
Ok ( True, stack )
JoyFalse ->
Ok ( False, stack )
_ ->
Err "Not a Boolean value."
-- Printer
joyTermToString : JoyType -> String
joyTermToString term =
case term of
JoySymbol name -> name
JoyInt n -> String.fromInt n
JoyTrue -> "true"
JoyFalse -> "false"
JoyList list ->
"[" ++ (joyExpressionToString list) ++ "]"
JoySymbol name ->
name
JoyInt n ->
String.fromInt n
JoyTrue ->
"true"
JoyFalse ->
"false"
JoyList list ->
"[" ++ joyExpressionToString list ++ "]"
joyExpressionToString expr =
String.join " " (List.map joyTermToString expr)
joyExpressionToString expr = String.join " " (List.map joyTermToString expr)
-- Use the old S-expression lexing trick.
tokenize : String -> (List String)
tokenize text = words (replace "[" " [ " (replace "]" " ] " text))
tokenize : String -> List String
tokenize text =
words (replace "[" " [ " (replace "]" " ] " text))
tokenator : String -> JoyType
tokenator tok =
case tok of
"true" -> JoyTrue
"false" -> JoyFalse
_ -> case String.toInt tok of
Just i -> JoyInt i
Nothing -> JoySymbol tok
"true" ->
JoyTrue
"false" ->
JoyFalse
_ ->
case String.toInt tok of
Just i ->
JoyInt i
Nothing ->
JoySymbol tok
-- I don't like this because it won't reject "[" and "]"
-- instead turning them into symbols!
expect_right_bracket : (List String) -> JList -> Result String (JList, List String)
expect_right_bracket : List String -> JList -> Result String ( JList, List String )
expect_right_bracket tokens acc =
case tokens of
[] -> Err "Missing closing bracket."
h :: t -> expect_right_bracket_one_token_lookahead h t acc
[] ->
Err "Missing closing bracket."
h :: t ->
expect_right_bracket_one_token_lookahead h t acc
expect_right_bracket_one_token_lookahead : String -> (List String) -> JList -> Result String (JList, List String)
expect_right_bracket_one_token_lookahead : String -> List String -> JList -> Result String ( JList, List String )
expect_right_bracket_one_token_lookahead token tokens acc =
case token of
"]" -> Ok (acc, tokens)
"]" ->
Ok ( acc, tokens )
"[" ->
-- (* extract the sub-list *)
case expect_right_bracket tokens [] of
Err msg -> Err msg
Err msg ->
Err msg
Ok ( sub_list, rest ) ->
-- (* continue looking for the expected "]" *)
case expect_right_bracket rest acc of
Err msg -> Err msg
Err msg ->
Err msg
Ok ( el, rrest ) ->
Ok ((JoyList sub_list) :: el, rrest)
Ok ( JoyList sub_list :: el, rrest )
_ ->
case expect_right_bracket tokens acc of
Err msg -> Err msg
Err msg ->
Err msg
Ok ( el, rest ) ->
Ok ((tokenator token) :: el, rest)
Ok ( tokenator token :: el, rest )
---(* token -> token list -> joy_type * token list *)
one_token_lookahead : String -> (List String) -> Result String (JoyType, List String)
one_token_lookahead : String -> List String -> Result String ( JoyType, List String )
one_token_lookahead token tokens =
case token of
"]" -> Err "Extra closing bracket."
"[" -> case expect_right_bracket tokens [] of
Err msg -> Err msg
Ok (list_term, rest_of_tokens) -> Ok (JoyList list_term, rest_of_tokens)
_ -> Ok (tokenator token, tokens)
"]" ->
Err "Extra closing bracket."
"[" ->
case expect_right_bracket tokens [] of
Err msg ->
Err msg
Ok ( list_term, rest_of_tokens ) ->
Ok ( JoyList list_term, rest_of_tokens )
_ ->
Ok ( tokenator token, tokens )
parse0 : (List String) -> JList -> Result String JList
parse0 : List String -> JList -> Result String JList
parse0 tokens acc =
case tokens of
[] -> Ok acc
[] ->
Ok acc
token :: tokens_tail ->
case one_token_lookahead token tokens_tail of
Err msg -> Err msg
Err msg ->
Err msg
Ok ( term, rest_of_tokens ) ->
case parse0 rest_of_tokens acc of
Err msg -> Err msg
Ok terms -> Ok (term :: terms)
Err msg ->
Err msg
Ok terms ->
Ok (term :: terms)
parse tokens = parse0 tokens []
parse tokens =
parse0 tokens []
text_to_expression text = parse (tokenize text)
text_to_expression text =
parse (tokenize text)
doit : String -> JoyDict -> Result String ( String, JoyDict )
@ -476,27 +721,40 @@ doit text dict =
case text_to_expression text of
Ok ast ->
case joy [] ast dict of
Ok (expr, dict0) -> Ok (joyExpressionToString expr, dict0)
Err msg -> Err msg
Err msg -> Err msg
Ok ( expr, dict0 ) ->
Ok ( joyExpressionToString expr, dict0 )
Err msg ->
Err msg
Err msg ->
Err msg
add_def : String -> JoyDict -> JoyDict
add_def def dict =
case text_to_expression def of
Err msg -> dict
Err msg ->
dict
Ok expr ->
case expr of
[] -> dict
[] ->
dict
sym :: body ->
-- check that name is a symbol
case sym of
JoySymbol name -> (insert name body dict)
_ -> dict
JoySymbol name ->
insert name body dict
_ ->
dict
initialize : JoyDict -> JoyDict
initialize dict = List.foldl (add_def) dict (lines """eq [false] [true] [false] cmp
initialize dict =
List.foldl add_def dict (lines """eq [false] [true] [false] cmp
gt [true] [false] [false] cmp
lt [false] [false] [true] cmp
neq [true] [false] [true] cmp
@ -627,4 +885,3 @@ _map2 [infrst] cons dipd roll< swons
_\\/_ [not not] [not] branch
/\\ [not not] ii [pop false] [] branch
\\/ [not not] ii [] [pop true] branch""")