text:
module ParserSpec (spec) where

import Test.Hspec
import Data.Either (either)
import Data.Ratio ((%))
import Data.Complex (Complex((:+)))

import Language.Ruby.Parser
import Language.Ruby.Parser.Builder
import Language.Ruby.AST

run :: String -> Term
run = either error id . parseRuby

test title code term = it (title ++ " [ " ++ code ++ " ]") $ do
                          run code `shouldBe` term

xtest title code _ = it (title ++ " [ " ++ code ++ " ]") $ do
                          pending

spec :: Spec
spec = do
  describe "parseRuby" $ do
    test "empty stmt" "" Nil

    test "nil" "nil" Nil

    test "nil_expression" "()" (Begin [])
    test "nil_expression" "begin end" (KWBegin [])

    test "true" "true" RTrue

    test "false" "false" RFalse

    test "int" "42" (RInt 42)
    test "int" "+42" (RInt 42)
    test "int" "-42" (RInt $ -42)

    -- test "int___LINE__" "__LINE__" (RInt 1)
    test "int___LINE__" "__LINE__" Line

    test "float" "1.33" (RFloat 1.33)
    test "float" "-1.33" (RFloat $ -1.33)
    test "float" "-1.335" (RFloat $ -1.335)

    -- test "rational" "42r" (RRational $ 42 % 1)
    -- test "rational" "42.1r" (RRational $ 421 % 10)

    test "complex" "42i" (RComplex $ 0 :+ 42)
    -- test "complex" "42ri" (RComplex $ 0 :+ (42 % 1))
    -- test "complex" "42.1i" (RComplex $ 0 :+ 42.1)
    -- test "complex" "42.1ri" (RComplex $ 0 :+ (421 % 10))

    test "string_plain" "'foobar'" (Str "foobar")
    test "string_plain" "%q(foobar)" (Str "foobar")

    test "self" "self" Self

    test "lvar" "foo" (Lvar "foo")
    test "ivar" "@foo" (Ivar "@foo")
    test "cvar" "@@foo" (Cvar "@@foo")
    test "gvar" "$foo" (Gvar "$foo")

    test "back_ref" "$+" (BackRef "$+")
    test "nth_ref" "$10" (NthRef 10)
    test "const_toplevel" "::Foo" (Const Cbase "Foo")
    test "const_scoped" "Bar::Foo" (Const (Const Nil "Bar") "Foo")
    test "const_unscoped" "Foo" (Const Nil "Foo")
    test "const__ENCODING__" "__ENCODING__" Encoding

    test "defined?" "defined? foo" (Defined [Lvar "foo"])
    test "defined?" "defined?(foo)" (Defined [Lvar "foo"])
    test "defined?" "defined? @foo" (Defined [Ivar "@foo"])

    test "lvasgn" "var = 10; var" (Begin [lvasgn "var" (RInt 10), Lvar "var"])
    test "ivasgn" "@var = 10"  (ivasgn "@var" (RInt 10))
    test "cvasgn" "@@var = 10"  (cvasgn "@@var" (RInt 10))
    test "gvasgn" "$var = 10"  (gvasgn "$var" (RInt 10))

    test "asgn_cmd" "foo = m foo"  (lvasgn "foo" (Send Nil "m" [Lvar "foo"]))
    test "asgn_cmd" "foo = bar = m foo"  (lvasgn "foo" (lvasgn "bar" (Send Nil "m" [Lvar "foo"])))

    test "casgn_toplevel" "::Foo = 10" (casgn Cbase "Foo"  (RInt 10))
    test "casgn_scoped" "Bar::Foo = 10" (casgn (Const Nil "Bar") "Foo"  (RInt 10))
    test "casgn_unscoped" "Foo = 10" (casgn Nil "Foo" (RInt 10))

    test "masgn" "foo, bar = 1, 2"          (Masgn (Mlhs [Lvasgn "foo" Nothing, Lvasgn "bar" Nothing]) (RArray [RInt 1, RInt 2]))
    test "masgn" "(foo, bar) = 1, 2"        (Masgn (Mlhs [Lvasgn "foo" Nothing, Lvasgn "bar" Nothing]) (RArray [RInt 1, RInt 2]))
    test "masgn" "foo, bar, baz = 1, 2"     (Masgn (Mlhs [Lvasgn "foo" Nothing, Lvasgn "bar" Nothing, Lvasgn "baz" Nothing]) (RArray [RInt 1, RInt 2]))

    test "masgn_splat" "@foo, @@bar = *foo" (Masgn (Mlhs [Ivasgn "@foo" Nothing, Cvasgn "@@bar" Nothing]) (RArray [Splat (Just (Lvar "foo"))]))
    test "masgn_splat" "a, b = *foo, bar"   (Masgn (Mlhs [Lvasgn "a" Nothing, Lvasgn "b" Nothing]) (RArray [Splat (Just (Lvar "foo")), Lvar "bar"]))
    test "masgn_splat" "a, *b = bar"        (Masgn (Mlhs [Lvasgn "a" Nothing, Splat (Just (Lvasgn "b" Nothing))]) (Lvar "bar"))
    test "masgn_splat" "a, *b, c = bar"     (Masgn (Mlhs [Lvasgn "a" Nothing, Splat (Just (Lvasgn "b" Nothing)), Lvasgn "c" Nothing]) (Lvar "bar"))

    test "masgn_splat" "a, * = bar"         (Masgn (Mlhs [Lvasgn "a" Nothing, Splat Nothing]) (Lvar "bar"))
    test "masgn_splat" "a, *, c = bar"      (Masgn (Mlhs [Lvasgn "a" Nothing, Splat Nothing, Lvasgn "c" Nothing]) (Lvar "bar"))
    test "masgn_splat" "*b = bar"           (Masgn (Mlhs [Splat (Just (Lvasgn "b" Nothing))]) (Lvar "bar"))
    test "masgn_splat" "*b, c = bar"        (Masgn (Mlhs [Splat (Just (Lvasgn "b" Nothing)), Lvasgn "c" Nothing]) (Lvar "bar"))
    test "masgn_splat" "* = bar"            (Masgn (Mlhs [Splat Nothing]) (Lvar "bar"))
    test "masgn_splat" "*, c, d = bar"      (Masgn (Mlhs [Splat Nothing, Lvasgn "c" Nothing, Lvasgn "d" Nothing]) (Lvar "bar"))

  --  test "masgn_nested" (
  --     s(:masgn,
  --       s(:mlhs,
  --         s(:lvasgn, :a),
  --         s(:mlhs,
  --           s(:lvasgn, :b),
  --           s(:lvasgn, :c))),
  --       s(:lvar, :foo)),
  --     %q{a, (b, c) = foo},

  -- test "masgn_nested" "((b, )) = foo" (
  --     s(:masgn,
  --       s(:mlhs,
  --         s(:lvasgn, :b)),
  --       s(:lvar, :foo)),

  -- test "masgn_attr" (
  --     s(:masgn,
  --       s(:mlhs,
  --         s(:send, s(:self), :a=),
  --         s(:indexasgn, s(:self), s(:int, 1), s(:int, 2))),
  --       s(:lvar, :foo)),
  --     %q{self.a, self[1, 2] = foo},
  --     %q{~~~~~~ expression (mlhs.send)
  --       |     ~ selector (mlhs.send)
  --       |            ^ begin (mlhs.indexasgn)
  --       |                 ^ end (mlhs.indexasgn)
  --       |        ~~~~~~~~~~ expression (mlhs.indexasgn)})

  -- test "masgn_attr" "self::a, foo = foo" (
  --     s(:masgn,
  --       s(:mlhs,
  --         s(:send, s(:self), :a=),
  --         s(:lvasgn, :foo)),
  --       s(:lvar, :foo)),

  -- test "masgn_attr" "self.A, foo = foo" (
  --     s(:masgn,
  --       s(:mlhs,
  --         s(:send, s(:self), :A=),
  --         s(:lvasgn, :foo)),
  --       s(:lvar, :foo)),

  -- test "masgn_const" "self::A, foo = foo" (
  --     s(:masgn,
  --       s(:mlhs,
  --         s(:casgn, s(:self), :A),
  --         s(:lvasgn, :foo)),
  --       s(:lvar, :foo)),

  -- test "masgn_const" "::A, foo = foo" (
  --     s(:masgn,
  --       s(:mlhs,
  --         s(:casgn, s(:cbase), :A),
  --         s(:lvasgn, :foo)),
  --       s(:lvar, :foo)),

    test "masgn_cmd" "foo, bar = m foo" (Masgn (Mlhs [Lvasgn "foo" Nothing, Lvasgn "bar" Nothing]) (Send Nil "m" [Lvar "foo"]))

    test "asgn_mrhs" "foo = bar, 1"     (Lvasgn "foo" (Just (RArray [Lvar "bar", RInt 1])))
    test "asgn_mrhs" "foo = *bar"       (Lvasgn "foo" (Just (RArray [Splat (Just (Lvar "bar"))])))
    test "asgn_mrhs" "foo = baz, *bar"  (Lvasgn "foo" (Just (RArray [Lvar "baz", Splat (Just (Lvar "bar"))])))

    test "def" "def foo; end" (Def "foo" (Args []) Nil)
    test "def" "def String; end" (Def "String" (Args []) Nil)
    test "def" "def String=; end" (Def "String=" (Args []) Nil)
    test "def" "def until; end" (Def "until" (Args []) Nil)
    test "def" "def BEGIN; end" (Def "BEGIN" (Args []) Nil)
    test "def" "def END; end" (Def "END" (Args []) Nil)

    test "defs" "def self.foo; end" (Defs Self "foo" (Args []) Nil)
    test "defs" "def self::foo; end" (Defs Self "foo" (Args []) Nil)
    test "defs" "def (foo).foo; end" (Defs (Lvar "foo") "foo" (Args []) Nil)
    test "defs" "def String.foo; end" (Defs (Const Nil "String") "foo" (Args []) Nil)
    test "defs" "def String::foo; end" (Defs (Const Nil "String") "foo" (Args []) Nil)

    test "undef" "undef foo" (Undef [Sym "foo"])
    test "undef" "undef foo, :bar, :\"foo#{1}\"" (Undef [Sym "foo", Sym "bar", Dsym [Str "foo", Begin [RInt 1]]])

    test "alias" "alias :foo bar" (Alias (Sym "foo") (Sym "bar"))

    test "alias_gvar" "alias $a $b" (Alias (Gvar "$a") (Gvar "$b"))
    test "alias_gvar" "alias $a $+" (Alias (Gvar "$a") (BackRef "$+"))

    test "string_interp" "\"foo#{bar}baz\"" (Dstr [Str "foo", Begin [Lvar "bar"], Str "baz"])
    test "string_dvar" "\"#@a #@@a #$a\"" (Dstr [Ivar "@a", Str " ", Cvar "@@a", Str " ", Gvar "$a"])
    test "string_concat" "\"foo#@a\" \"bar\"" (Dstr [Dstr [Str "foo", Ivar "@a"], Str "bar"])
    test "string_concat" "'aaa' 'bbb'" (Dstr [Str "aaa", Str "bbb"])
    test "string_concat" "\"aaa\" \"bbb\"" (Dstr [Str "aaa", Str "bbb"])
  --  test "string___FILE__" "__FILE__" (Str "(assert_parses)")
    test "string___FILE__" "__FILE__" File
    test "character" "?a" (Str "a")

  --   test "heredoc" "<<HERE\nfoo\nbar\nHERE" (Dstr [Str "foo\n", Str "bar\n"])
  --   test "heredoc" "<<'HERE'\nfoo\nbar\nHERE" (Dstr [Str "foo\n", Str "bar\n"])
  --   test "heredoc" "<<`HERE`\nfoo\nbar\nHERE" (Dstr [Str "foo\n", Str "bar\n"])
  -- test "dedenting_heredoc" "p <<~E\nE" (Send Nil "p" (Dstr [])
  -- test "dedenting_heredoc" "p <<~E\n  E" (Send Nil "p" (Dstr [])
  -- test "dedenting_heredoc" "p <<~E\n  x\nE" (Send Nil "p" (Str "x\n")
  -- test "dedenting_heredoc" "p <<~E\n  x\n    y\nE" (Send Nil "p" (Dstr [Str "x\n", Str "  y\n"]))

  -- test "dedenting_heredoc" "p <<~E\n\tx\n    y\nE" (Send Nil "p" (Dstr [Str "x\n", Str "y\n"]))
  -- test "dedenting_heredoc" "p <<~E\n\tx\n        y\nE" (Send Nil "p" (Dstr [Str "x\n", Str "y\n"]))
  -- test "dedenting_heredoc" "p <<~E\n    \tx\n        y\nE" (Send Nil "p" (Dstr [Str "x\n", Str "y\n"]))
  -- test "dedenting_heredoc" "p <<~E\n        \tx\n\ty\nE" (Send Nil "p" (Dstr [Str "\tx\n", Str "y\n"]))
  -- test "dedenting_heredoc" "p <<~E\n  x\n\ny\nE" (Send Nil "p" (Dstr [Str "  x\n", Str "\n", Str "y\n"]))
  -- test "dedenting_heredoc" "p <<~E\n  x\n    \n  y\nE" (Send Nil "p" (Dstr [Str "x\n", Str "   \n", Str "y\n"]))

  --   assert_parses(
  --     (Send Nil, :p,
  --       (Dstr
  --         (Str "  x\n"),
  --         (Str "  y\n"))),
  --     %Q{p <<~E\n    x\n  \\  y\nE},
  --     %q{},

  --   assert_parses(
  --     (Send Nil, :p,
  --       (Dstr
  --         (Str "  x\n"),
  --         (Str "\ty\n"))),
  --     %Q{p <<~E\n    x\n  \\\ty\nE},
  --     %q{},

  --   assert_parses(
  --     (Send Nil, :p,
  --       (Dstr
  --         (Str "  x\n"),
  --         (Str ""),
  --         (Begin
  --           (Lvar :foo)),
  --         (Str "\n"))),
  --     %Q{p <<~"E"\n    x\n  \#{foo}\nE},
  --     %q{},

  --   assert_parses(
  --     (Send Nil, :p,
  --       s(:xstr,
  --         (Str "  x\n"),
  --         (Str ""),
  --         (Begin
  --           (Lvar :foo)),
  --         (Str "\n"))),
  --     %Q{p <<~`E`\n    x\n  \#{foo}\nE},
  --     %q{},

  --   assert_parses(
  --     (Send Nil, :p,
  --       (Dstr
  --         (Str "  x\n"),
  --         (Str ""),
  --         (Begin
  --           (Str "  y")),
  --         (Str "\n"))),
  --     %Q{p <<~"E"\n    x\n  \#{"  y"}\nE},
  --     %q{},
  -- end

  -- # Symbols

  -- test "symbol_plain" ":foo" (Sym :foo)
  -- test "symbol_plain" ":'foo'" (Sym :foo)

  -- test "symbol_interp"
  --   assert_parses(
  --     (Dsym
  --       (Str 'foo'),
  --       (Begin (Lvar :bar)),
  --       (Str 'baz')),
  --     %q{:"foo#{bar}baz"},

  -- end

  -- # Execute-strings

  -- test "xstring_plain"
  --   assert_parses(
  --     s(:xstr, (Str 'foobar')),
  --     %q{`foobar`},
  --     %q{^ begin
  --       |       ^ end
  --       |~~~~~~~~ expression})
  -- end

  -- test "xstring_interp"
  --   assert_parses(
  --     s(:xstr,
  --       (Str 'foo'),
  --       (Begin (Lvar :bar)),
  --       (Str 'baz')),
  --     %q{`foo#{bar}baz`},

  -- -- Regexp

  -- test "regex_plain"
  --   assert_parses(
  --     s(:regexp, (Str 'source'), s(:regopt, :i, :m)),
  --     %q{/source/im},

  -- test "regex_interp"
  --   assert_parses(
  --     s(:regexp,
  --       (Str 'foo'),
  --       (Begin (Lvar :bar)),
  --       (Str 'baz'),
  --       s(:regopt)),
  --     %q{/foo#{bar}baz/},

  -- end

  -- -- Arrays

  -- test "array_plain"
  --   assert_parses(
  --     (Array, (RInt 1), (RInt 2)),
  --     %q{[1, 2]},

  -- test "array_splat"
  --   assert_parses(
  --     (Array,
  --       (RInt 1),
  --       s(:splat, (Lvar :foo)),
  --       (RInt 2)),
  --     %q{[1, *foo, 2]},

  --   assert_parses(
  --     (Array,
  --       (RInt 1),
  --       s(:splat, (Lvar :foo))),
  --     %q{[1, *foo]},

  --   assert_parses(
  --     (Array,
  --       s(:splat, (Lvar :foo))),
  --     %q{[*foo]})
  -- end

  -- test "array_assocs"
  --   assert_parses(
  --     (Array,
  --       (Hash (Pair (RInt 1), (RInt 2)))),
  --     %q{[ 1 => 2 ]},

  --   assert_parses(
  --     (Array,
  --       (RInt 1),
  --       (Hash (Pair (RInt 2), (RInt 3)))),
  --     %q{[ 1, 2 => 3 ]},
  -- end

  -- test "array_words" "%w[foo bar]" (Array [Str 'foo', Str 'bar'])
  -- test "array_words_interp" "%W[foo #{bar}" (Array [Str 'foo', Dstr [Begin [Lvar "bar"]]])
  -- test "array_words_interp" "%W[foo #{bar}foo#@baz]" (Array [Str 'foo', Dstr [Begin [Lvar "bar"], Str "foo", Ivar "@baz"]])
  -- test "array_words_empty" "%w[]" (Array [])
  -- test "array_symbols" "%i[foo bar]" (Array [Sym "foo", Sym "bar"])
  -- test "array_symbols_interp" "%I[foo #{bar}]" (Array [Dsym [Str 'foo', Begin [Lvar "bar"]]])
  -- test "array_symbols_interp" "%I[foo#{bar}]" (Array [Dsym [Str 'foo', Begin [Lvar "bar"]]])

  -- test "array_symbols_empty" "%i[]" (Array [])
  -- test "array_symbols_empty" "%I()" (Array [])

  -- test "hash_label" "{ foo: 2 }" (Hash (Pair (Sym "foo"), (RInt 2)))

  -- test "hash_label_end" "{ 'foo': 2 }"
  --     (Hash (Pair (Sym "foo"), (RInt 2))),

  -- test "hash_label_end" "{ 'foo': 2, 'bar': {}}"
  --     (Hash
  --       (Pair (Sym :foo) (RInt 2)),
  --       (Pair (Sym :bar) (Hash))),

  -- test "hash_kwsplat" "{ foo: 2, **bar }" (Hash (Pair (Sym :foo) (RInt 2)) (Kwsplat (Lvar :bar)))

  -- -- Range

    test "range_inclusive" "1..2" (IRange (RInt 1) (RInt 2))
    test "range_inclusive" "1 .. 2" (IRange (RInt 1) (RInt 2))
    test "range_exclusive" "1...2"  (ERange (RInt 1) (RInt 2))
    test "range_exclusive" "1 ... 2"  (ERange (RInt 1) (RInt 2))

    test "range_endless" "1.." (IRange (RInt 1) Nil)
    test "range_endless" "1 .. " (IRange (RInt 1) Nil)
    test "range_endless" "1..." (ERange (RInt 1) Nil)
    test "range_endless" "1 ... " (ERange (RInt 1) Nil)

    test "if" "if foo then bar; end" (If (Lvar "foo") (Lvar "bar") Nil)
    test "if" "if foo; bar; end" (If (Lvar "foo") (Lvar "bar") Nil)

    test "if_nl_then" "if foo\nthen bar end" (If (Lvar "foo") (Lvar "bar") Nil)

    test "if_mod" "bar if foo" (If (Lvar "foo") (Lvar "bar") Nil)

    test "unless" "unless foo then bar; end" (If (Lvar "foo") Nil (Lvar "bar"))
    test "unless" "unless foo; bar; end" (If (Lvar "foo") Nil (Lvar "bar"))

    xtest "unless_mod" "bar unless foo" (If (Lvar "foo") Nil (Lvar "bar"))

    test "if_else" "if foo then bar; else baz; end" (If (Lvar "foo") (Lvar "bar") (Lvar "baz"))
    test "if_else" "if foo; bar; else baz; end" (If (Lvar "foo") (Lvar "bar") (Lvar "baz"))

    test "unless_else" "unless foo then bar; else baz; end" (If (Lvar "foo") (Lvar "baz") (Lvar "bar"))
    test "unless_else" "unless foo; bar; else baz; end" (If (Lvar "foo") (Lvar "baz") (Lvar "bar"))

    test "if_elsif" "if foo; bar; elsif baz; 1; else 2; end" (If (Lvar "foo") (Lvar "bar") (If (Lvar "baz") (RInt 1) (RInt 2)))

    xtest "ternary" "foo ? 1 : 2" (If (Lvar "foo") (RInt 1) (RInt 2))

    xtest "ternary_ambiguous_symbol" "t=1;(foo)?t:T" (Begin [Lvasgn "t" (Just $ RInt 1), If (Begin [Lvar "foo"]) (Lvar "t") (Const Nil "T")])

    test "if_masgn__24" "if (a, b = foo); end" (If (Begin [Masgn (Mlhs [Lvasgn "a" Nothing, Lvasgn "b" Nothing]) (Lvar "foo")]) Nil Nil)

    test "not_masgn__24" "!(a, b = foo)" (Send (Begin [Masgn (Mlhs [Lvasgn "a" Nothing, Lvasgn "b" Nothing]) (Lvar "foo")]) "!" [])

    test "cond_begin" "if (bar); foo; end" (If (Begin [Lvar "bar"]) (Lvar "foo") Nil)

    test "cond_begin_masgn" "if (bar; a, b = foo); end" (If (Begin [Lvar "bar", Masgn (Mlhs [Lvasgn "a" Nothing, Lvasgn "b" Nothing]) (Lvar "foo")]) Nil Nil)

    --test "cond_match_current_line" "if /wat/; end" (If (MatchCurrentLine (Regexp (Str "wat") (Regopt))) Nil Nil)

    --test "cond_match_current_line" "!/wat/" (Send (MatchCurrentLine (Regexp (Str "wat") (Regopt))) "!")

    test "not" "not foo" (Send (Lvar "foo") "!" [])
    test "not" "not(foo)" (Send (Lvar "foo") "!" [])
    test "not" "not()" (Send (Begin []) "!" [])

    test "not_cmd" "not m foo" (Send (Send Nil "m" [Lvar "foo"]) "!" [])

    test "send_binary_op" "foo + 1"   (Send (Lvar "foo") "+"    [RInt 1])
    test "send_binary_op" "foo - 1"   (Send (Lvar "foo") "-"    [RInt 1])
    test "send_binary_op" "foo * 1"   (Send (Lvar "foo") "*"    [RInt 1])
    test "send_binary_op" "foo / 1"   (Send (Lvar "foo") "/"    [RInt 1])
    test "send_binary_op" "foo % 1"   (Send (Lvar "foo") "%"    [RInt 1])
    test "send_binary_op" "foo ** 1"  (Send (Lvar "foo") "**"   [RInt 1])
    test "send_binary_op" "foo | 1"   (Send (Lvar "foo") "|"    [RInt 1])
    test "send_binary_op" "foo ^ 1"   (Send (Lvar "foo") "^"    [RInt 1])
    test "send_binary_op" "foo & 1"   (Send (Lvar "foo") "&"    [RInt 1])
    test "send_binary_op" "foo <=> 1" (Send (Lvar "foo") "<=>"  [RInt 1])
    test "send_binary_op" "foo < 1"   (Send (Lvar "foo") "<"    [RInt 1])
    test "send_binary_op" "foo <= 1"  (Send (Lvar "foo") "<="   [RInt 1])
    test "send_binary_op" "foo > 1"   (Send (Lvar "foo") ">"    [RInt 1])
    test "send_binary_op" "foo >= 1"  (Send (Lvar "foo") ">="   [RInt 1])
    test "send_binary_op" "foo == 1"  (Send (Lvar "foo") "=="   [RInt 1])
    test "send_binary_op" "foo != 1"  (Send (Lvar "foo") "!="   [RInt 1])
    test "send_binary_op" "foo === 1" (Send (Lvar "foo") "==="  [RInt 1])
    test "send_binary_op" "foo =~ 1"  (Send (Lvar "foo") "=~"   [RInt 1])
    test "send_binary_op" "foo !~ 1"  (Send (Lvar "foo") "!~"   [RInt 1])
    test "send_binary_op" "foo << 1"  (Send (Lvar "foo") "<<"   [RInt 1])
    test "send_binary_op" "foo >> 1"  (Send (Lvar "foo") ">>"   [RInt 1])

    test "send_unary_op" "-foo" (Send (Lvar "foo") "-@" [])
    test "send_unary_op" "+foo" (Send (Lvar "foo") "+@" [])
    test "send_unary_op" "~foo" (Send (Lvar "foo") "~" [])

    test "and" "foo and bar" (And (Lvar "foo") (Lvar "bar"))
    test "and" "foo && bar" (And (Lvar "foo") (Lvar "bar"))

    test "or" "foo or bar" (Or (Lvar "foo") (Lvar "bar"))
    test "or" "foo || bar" (Or (Lvar "foo") (Lvar "bar"))

    test "and_or_masgn" "foo && (a, b = bar)" (And (Lvar "foo") (Begin [Masgn (Mlhs [Lvasgn "a" Nothing, Lvasgn "b" Nothing]) (Lvar "bar")]))
    test "and_or_masgn" "foo || (a, b = bar)" (Or (Lvar "foo") (Begin [Masgn (Mlhs [Lvasgn "a" Nothing, Lvasgn "b" Nothing]) (Lvar "bar")]))

    test "case_expr" "case foo; when 'bar'; bar; end" (Case [Lvar "foo", When [Str "bar", Lvar "bar"], Nil])

    test "case_expr_else" "case foo; when 'bar'; bar; else baz; end" (Case [Lvar "foo", When [Str "bar", Lvar "bar"], Lvar "baz"])

    test "case_cond" "case; when foo; 'foo'; end" (Case [Nil, When [Lvar "foo", Str "foo"], Nil])

    test "case_cond_else" "case; when foo; 'foo'; else 'bar'; end" (Case [Nil, When [Lvar "foo", Str "foo"], Str "bar"])

    test "case_cond_just_else" "case; else 'bar'; end" (Case [Nil, Str "bar"])

    test "when_then" "case foo; when 'bar' then bar; end" (Case [Lvar "foo", When [Str "bar", Lvar "bar"], Nil])

    test "when_multi" "case foo; when 'bar', 'baz'; bar; end" (Case [Lvar "foo", When [Str "bar", Str "baz", Lvar "bar"], Nil])

    test "when_splat" "case foo; when 1, *baz; bar; when *foo; end" (Case [Lvar "foo", When [RInt 1, Splat (Just (Lvar "baz")), Lvar "bar"], When [Splat (Just (Lvar "foo")), Nil], Nil])

    test "for" "for a in foo do p a; end" (For (Lvasgn "a" Nothing) (Lvar "foo") (Send Nil "p" [Lvar "a"]))

    test "for" "for a in foo; p a; end" (For (Lvasgn "a" Nothing) (Lvar "foo") (Send Nil "p" [Lvar "a"]))

    test "for_mlhs" "for a, b in foo; p a, b; end" (For (Mlhs [Lvasgn "a" Nothing, Lvasgn "b" Nothing]) (Lvar "foo") (Send Nil "p" [Lvar "a", Lvar "b"]))

    xtest "postexe" "END { 1 }" (Postexe (RInt 1))

    test "while" "while foo do meth end" (While (Lvar "foo") (Send Nil "meth" []))
    xtest "while" "while foo; meth end" (While (Lvar "foo") (Send Nil "meth" []))

    test "until" "until foo do meth end" (Until (Lvar "foo") (Send Nil "meth" []))
    test "until" "until foo; meth end" (Until (Lvar "foo") (Send Nil "meth" []))

    test "while_mod" "meth while foo" (While (Lvar "foo") (Send Nil "meth" []))

    test "until_mod" "meth until foo" (Until (Lvar "foo") (Send Nil "meth" []))

    test "while_post" "begin meth end while foo" (WhilePost (Lvar "foo") (KWBegin [Send Nil "meth" []]))

    test "until_post" "begin meth end until foo" (UntilPost (Lvar "foo") (KWBegin [Send Nil "meth" []]))

    test "rescue" "begin; meth; rescue; foo; end" (KWBegin [Rescue (Send Nil "meth" []) [Resbody Nil Nil (Lvar "foo"), Nil]])

    test "rescue_else" "begin; meth; rescue; foo; else; bar; end" (KWBegin [Rescue (Send Nil "meth" []) [Resbody Nil Nil (Lvar "foo"), (Lvar "bar")]])

    test "ensure" "begin; meth; ensure; bar; end" (KWBegin [Ensure (Send Nil "meth" []) (Lvar "bar")])

    test "ensure_empty" "begin ensure end" (KWBegin [Ensure Nil Nil])

    test "rescue_ensure" "begin; meth; rescue; baz; ensure; bar; end" (KWBegin [Ensure (Rescue (Send Nil "meth" []) [Resbody Nil Nil (Lvar "baz"), Nil]) (Lvar "bar")])

    test "rescue_else_ensure" "begin; meth; rescue; baz; else foo; ensure; bar end" (KWBegin [Ensure (Rescue (Send Nil "meth" []) [Resbody Nil Nil (Lvar "baz"), Lvar "foo"]) (Lvar "bar")])

    test "rescue_mod" "meth rescue bar" (Rescue (Send Nil "meth" []) [Resbody Nil Nil (Lvar "bar"), Nil])

    xtest "rescue_mod_asgn" "foo = meth rescue bar" (Lvasgn "foo" (Just $ Rescue (Send Nil "meth" []) [Resbody Nil Nil (Lvar "bar"), Nil]))

    --test "rescue_mod_op_assign" "foo += meth rescue bar" (Op_asgn (Lvasgn "foo" Nothing), "+", (Rescue (Send Nil "meth" []), (Resbody Nil Nil (Lvar "bar")), Nil))

    --test "rescue_without_begin_end" "meth do; foo; rescue; bar; end" (Block, (Send Nil "meth" []), (Args), (Rescue (Lvar "foo"), (Resbody Nil Nil (Lvar "bar")), Nil))

    test "resbody_list" "begin; meth; rescue Exception; bar; end" (KWBegin [Rescue (Send Nil "meth" []) [Resbody (RArray [Const Nil "Exception"]) Nil (Lvar "bar"), Nil]])

    test "resbody_list_mrhs" "begin; meth; rescue Exception, foo; bar; end" (KWBegin [Rescue (Send Nil "meth" []) [Resbody (RArray [Const Nil "Exception", Lvar "foo"]) Nil (Lvar "bar"), Nil]])

    test "resbody_var" "begin; meth; rescue => ex; bar; end" (KWBegin [Rescue (Send Nil "meth" []) [Resbody Nil (Lvasgn "ex" Nothing) (Lvar "bar"), Nil]])

    xtest "resbody_var" "begin; meth; rescue => @ex; bar; end" (KWBegin [Rescue (Send Nil "meth" []) [Resbody Nil (Ivasgn "@ex" Nothing) (Lvar "bar"), Nil]])

    xtest "resbody_list_var" "begin; meth; rescue foo => ex; bar; end" (KWBegin [Rescue (Send Nil "meth" []) [Resbody (RArray [Lvar "foo"]) (Lvasgn "ex" Nothing) (Lvar "bar"), Nil]])

    test "retry" "retry" (Retry [])

    xtest "hash_empty" "{ }" (Hash [])

    xtest "hash_hashrocket" "{ 1 => 2 }" (Hash [Pair (RInt 1) (RInt 2)])

    xtest "hash_hashrocket" "{ 1 => 2, :foo => \"bar\" }]" (Hash [Pair (RInt 1) (RInt 2), Pair (Sym "foo") (Str "bar")])

    xtest "hash_label" "{ foo: 2 }" (Hash [Pair (Sym "foo") (RInt 2)])

    xtest "hash_label_end" "{ 'foo': 2 }" (Hash [Pair (Sym "foo") (RInt 2)])

    xtest "hash_label_end" "{ 'foo': 2, 'bar': {}}" (Hash [Pair (Sym "foo") (RInt 2), Pair (Sym "bar") (Hash [])])

    xtest "hash_label_end" "f(a ? \"a\":1)" (Send Nil "f" [If (Send Nil "a" []) (Str "a") (RInt 1)])

    xtest "hash_kwsplat" "{ foo: 2, **bar }" (Hash [Pair (Sym "foo") (RInt 2), KWSplat (Lvar "bar")])

    xtest "hash_no_hashrocket" "{ 1, 2 }" (Hash [Pair (RInt 1) (RInt 2)])

    test "args_cmd" "fun(f bar)" (Send Nil "fun" [Send Nil "f" [Lvar "bar"]])

    xtest "args_args_star" "fun(foo, *bar)" (Send Nil "fun" [Lvar "foo", Splat $ Just (Lvar "bar")])

    xtest "args_args_star" "fun(foo, *bar, &baz)" (Send Nil "fun" [Lvar "foo", Splat $ Just (Lvar "bar"), BlockPass (Lvar "baz")])

    xtest "args_star" "fun(*bar)" (Send Nil "fun" [Splat $ Just (Lvar "bar")])

    xtest "args_star" "fun(*bar, &baz)" (Send Nil "fun" [Splat $ Just (Lvar "bar"), BlockPass (Lvar "baz")])

    xtest "args_block_pass" "fun(&bar)" (Send Nil "fun" [BlockPass (Lvar "bar")])

    --test "args_args_comma" "foo[bar,]" (Index, (Lvar "foo"), (Lvar "bar"))

    xtest "args_assocs" "fun(:foo => 1)" (Send Nil "fun" [Hash [Pair (Sym "foo") (RInt 1)]])

    xtest "args_assocs" "fun(:foo => 1, &baz)" (Send Nil "fun" [Hash [Pair (Sym "foo") (RInt 1)], BlockPass (Lvar "baz")])

    --test "args_assocs_comma" "foo[:baz => 1,]" (Index, (Lvar "foo"), (Hash (Pair, (Sym "baz"), (RInt, 1))))

    xtest "args_args_assocs" "fun(foo, :foo => 1)" (Send Nil "fun" [Lvar "foo", Hash [Pair (Sym "foo") (RInt 1)]])

    xtest "args_args_assocs" "fun(foo, :foo => 1, &baz)" (Send Nil "fun" [Lvar "foo", Hash [Pair (Sym "foo") (RInt 1)], BlockPass (Lvar "baz")])

    --test "args_args_assocs_comma" "foo[bar, :baz => 1,]" (Index, (Lvar "foo"), (Lvar "bar"), (Hash (Pair, (Sym "baz"), (RInt, 1))))

    test "space_args_cmd" "fun (f bar)" (Send Nil "fun" [Begin [Send Nil "f" [Lvar "bar"]]])

    test "space_args_arg" "fun (1)" (Send Nil "fun" [Begin [RInt 1]])

    test "space_args_arg_newline" "fun (1\n)" (Send Nil "fun" [Begin [RInt 1]])

    --test "space_args_arg_block" "fun (1) {}" (Block (Send Nil "fun", (Begin (RInt, 1))), (Args), Nil)

    --test "space_args_arg_block" "foo.fun (1) {}" (Block (Send (Lvar "foo"), "fun", (Begin (RInt, 1))), (Args), Nil)

    xtest "space_args_arg_call" "fun (1).to_i" (Send Nil "fun" [Send (Begin [RInt 1]) "to_i" []])

max_stars_repo_name: flbulgarelli/language-ruby

max_issues_repo_name: flbulgarelli/language-ruby

max_forks_repo_name: flbulgarelli/language-ruby


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
module Statistics.Distribution.Random.Exponential (
    exponential
) where

import Random.CRI
import Statistics.Distribution.Random.Uniform

-- q[k-1] = sum(log(2)^k / k!)  k=1,..,n,
q :: [Double]
-- q = let factorial = foldr (*) 1 . enumFromTo 1
--         qk :: Integer -> Double
--         qk k = (log 2)^k / (fromIntegral (factorial k))
--         qs :: [Double]
--         qs = map qk [1..]
--     in map (\ n -> sum (take n qs)) (take 16 [1..])
q = [0.6931471805599453,
     0.9333736875190459,
     0.9888777961838675,
     0.9984959252914960,
     0.9998292811061389,
     0.9999833164100727,
     0.9999985691438767,
     0.9999998906925558,
     0.9999999924734159,
     0.9999999995283275,
     0.9999999999728814,
     0.9999999999985598,
     0.9999999999999289,
     0.9999999999999968,
     0.9999999999999999,
     1.0000000000000000]
{-# INLINE q #-}

exponential :: Source m g Double => g m -> m Double
exponential rng =
    let !q0 = q !! 0
        mk_au :: Double -> Double -> (Double, Double)
        mk_au !a !u
            | u > 1.0   = (a, u - 1.0)
            | otherwise = mk_au (a + q0) (u + u)

        go a _ umin ![] = return (a + umin * q0)
        go a u umin !(qi:qs) = do
            !ustar <- uniform rng
            let umin' = min ustar umin
            if u > qi
                then go a u umin' qs
                else return (a + umin' * q0)
    in do
        !u' <- uniform rng
        let !(a, u) = mk_au 0.0 (u' + u')
        if u <= q0
            then return (a + u)
            else do
                !us <- uniform rng
                go a u us (tail q)

ext: hs

max_stars_repo_name: finlay/random-dist

max_issues_repo_name: finlay/random-dist

max_forks_repo_name: finlay/random-dist


text:
{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -fno-warn-orphans  #-}

import           Control.DeepSeq
import           Control.Lens hiding                          ((<.>))
import           Control.Monad.Primitive
import           Control.Monad.Trans.Maybe
import           Data.Bitraversable
import           Data.Default
import           Data.IDX
import           Data.Mutable
import           Data.Traversable
import           Data.Tuple
import           GHC.Generics                                 (Generic)
import           GHC.TypeLits
import           Numeric.Backprop hiding                      (auto)
import           Numeric.LinearAlgebra.Static.Backprop hiding ((<>))
import           Numeric.OneLiner
import           Numeric.Opto hiding                          ((<.>))
import           Numeric.Opto.Backprop
import           Numeric.Opto.Run.Simple
import           Options.Applicative
import           System.FilePath hiding                       ((<.>))
import           Text.Printf
import qualified Data.Vector.Generic                          as VG
import qualified Numeric.LinearAlgebra                        as HM
import qualified Numeric.LinearAlgebra.Static                 as H
import qualified System.Random.MWC                            as MWC

data OMode = OSingle
           | OParallel Bool Int

data Opts = Opts
    { oDataDir :: FilePath
    , oReport  :: Int
    , oBatch   :: Int
    , oMode    :: OMode
    }

parseOMode :: Parser OMode
parseOMode = subparser
    ( command "single" (info (pure OSingle) (progDesc "Single-threaded"))
   <> command "parallel" (info (uncurry OParallel <$> parseParallel) (progDesc "Parallel"))
    )
  where
    parseParallel :: Parser (Bool, Int)
    parseParallel = (,)
        <$> switch (long "chunked" <> help "Chunked mode")
        <*> option auto
                ( long "split"
               <> short 's'
               <> help "Number of items per thread"
               <> metavar "INT"
               <> showDefault
               <> value 750
                )

parseOpts :: Parser Opts
parseOpts = Opts
    <$> strArgument ( help "Data directory (containing uncompressed MNIST data set)"
                   <> metavar "DIR"
                    )
    <*> option auto
          ( long "report"
         <> short 'r'
         <> help "Report frequency (in batches)"
         <> metavar "INT"
         <> showDefault
         <> value 2500
          )
    <*> option auto
          ( long "batch"
         <> short 'b'
         <> help "Batching amount"
         <> metavar "INT"
         <> showDefault
         <> value 1
          )
    <*> (parseOMode <|> pure OSingle)

data Net = N { _weights1 :: !(L 250 784)
             , _bias1    :: !(R 250)
             , _weights2 :: !(L 10 250)
             , _bias2    :: !(R 10)
             }
  deriving (Generic)
  deriving (Num, Fractional, Floating) via (GNum Net)
makeLenses ''Net

instance Linear Double Net
instance Mutable q Net
instance LinearInPlace q Double Net

logistic :: Floating a => a -> a
logistic x = 1 / (1 + exp (-x))

softMax
    :: Reifies s W
    => BVar s (R 10)
    -> BVar s (R 10)
softMax x = expx / konst (norm_1V expx)
  where
    expx = exp x

crossEntropy
    :: Reifies s W
    => BVar s (R 10)
    -> BVar s (R 10)
    -> BVar s Double
crossEntropy targ res = -(log res <.> targ)

runNet
    :: Reifies s W
    => BVar s Net
    -> BVar s (R 784)
    -> BVar s (R 10)
runNet n x = z
  where
    y = logistic $ (n ^^. weights1) #> x + (n ^^. bias1)
    z = softMax  $ (n ^^. weights2) #> y + (n ^^. bias2)

netErr
    :: Reifies s W
    => BVar s (R 784)
    -> BVar s (R 10)
    -> BVar s Net
    -> BVar s Double
netErr x targ n = crossEntropy targ (runNet n x)

-- *********************************************
-- Plumbing for running the network on real data
-- *********************************************

main :: IO ()
main = MWC.withSystemRandom $ \g -> do
    Opts{..} <- execParser $ info (parseOpts <**> helper)
        ( fullDesc
       <> progDesc "Run optimizer samples on MNIST"
       <> header "opto-neural - opto runner on MNIST data set"
        )

    Just train <- loadMNIST (oDataDir </> "train-images-idx3-ubyte")
                            (oDataDir </> "train-labels-idx1-ubyte")
    Just test  <- loadMNIST (oDataDir </> "t10k-images-idx3-ubyte")
                            (oDataDir </> "t10k-labels-idx1-ubyte")
    putStrLn "Loaded data."
    net0 <- MWC.uniformR (-0.5, 0.5) g

    let o :: Opto (PrimState IO) (R 784, R 10) Net
        o = adam def $
              bpGradSample $ \(x, y) -> netErr (constVar x) (constVar y)

        runTest chnk net = printf "Error: %.2f%%" ((1 - score) * 100)
          where
            score = testNet chnk net

        ro = def { roBatch = oBatch
                 }
        so = def { soTestSet   = Just test
                 , soEvaluate  = runTest
                 , soSkipSamps = oReport
                 }

    case oMode of
      OSingle       -> simpleRunner so train SOSingle ro net0 o g
      OParallel c s -> do
        let po = def { poSplit = s }
        if c
          then simpleRunner so train (SOParallel   po) ro net0 o g
          else simpleRunner so train (SOParChunked po) ro net0 o g

testNet :: [(R 784, R 10)] -> Net -> Double
testNet xs n = sum (map (uncurry test) xs) / fromIntegral (length xs)
  where
    test x (H.extract->t)
        | HM.maxIndex t == HM.maxIndex (H.extract r) = 1
        | otherwise                                  = 0
      where
        r = evalBP (`runNet` constVar x) n

loadMNIST
    :: FilePath
    -> FilePath
    -> IO (Maybe [(R 784, R 10)])
loadMNIST fpI fpL = runMaybeT $ do
    i <- MaybeT          $ decodeIDXFile       fpI
    l <- MaybeT          $ decodeIDXLabelsFile fpL
    d <- MaybeT . return $ labeledIntData l i
    MaybeT . return $ for d (bitraverse mkImage mkLabel . swap)
  where
    mkImage = H.create . VG.convert . VG.map (\i -> fromIntegral i / 255)
    mkLabel n = H.create $ HM.build 10 (\i -> if round i == n then 1 else 0)

instance KnownNat n => MWC.Variate (R n) where
    uniform g = H.randomVector <$> MWC.uniform g <*> pure H.Uniform
    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g

instance (KnownNat m, KnownNat n) => MWC.Variate (L m n) where
    uniform g = H.uniformSample <$> MWC.uniform g <*> pure 0 <*> pure 1
    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g

instance MWC.Variate Net where
    uniform g = N <$> MWC.uniform g
                  <*> MWC.uniform g
                  <*> MWC.uniform g
                  <*> MWC.uniform g
    uniformR (l, h) g = (\x -> x * (h - l) + l) <$> MWC.uniform g

instance NFData Net

instance Backprop Net

max_stars_repo_name: mstksg/opto

max_issues_repo_name: mstksg/opto

max_forks_repo_name: mstksg/opto


text:
module QLib
    ( quantumRun
    ) where

import Data.Complex
import Data.Bits
import qualified Data.List as L
import Text.Printf
import Numeric.LinearAlgebra

quantumRun :: IO ()
quantumRun = do putStrLn "Some Func"
                let a = newRegister 4
                putStrLn $ show a
--                putStrLn $ printf "%b" (3 :: Int)
--                let c = Qubit $ fromList [1 :+ 0, 0]
--                putStrLn $ show c
--                let d = sauliX c
--                putStrLn $ show d
--                let e = Register $ take 5 $ repeat (Qubit $ fromList [1, 0])
--                --let e = sauliZ d
--                putStrLn $ show e

--data Qubit = Qubit (Double, Int)
data Qubit = Qubit { probability :: Double, qubit :: Int }

instance Eq Qubit where
    x == y = qubit x == qubit y

instance Ord Qubit where
    x <= y = qubit x <= qubit y

instance Show Qubit where
    show x = (show . probability $ x) ++ " |" ++ (show . qubit $ x) ++ ">"

data Register = Register { nStates :: Int, qubits :: [Qubit] }

instance Show Register where
    --show (Register a x) = (show a) (show x) ++ ">"
    show x = concatMap ((flip (++) "\n") . show) $ qubits x

instance Eq Register where
    x == y = qubits x == qubits y

newRegister :: Int -> Register
newRegister n = Register { nStates = n, qubits = [blankQubit (x-1) | x <- [1..2^n] ] }
                where blankQubit 0 = Qubit { probability = 1.0, qubit = 0 }
                      blankQubit y = Qubit { probability = 0.0, qubit = y }

sauliX :: Register -> Int -> Register
sauliX xs pos = map (\x -> x `xor` pos) xs

--newRegister :: Int -> QuantumRegister
--newRegister 0 = QuantumRegister 0 []
--newRegister 1 = QuantumRegister 1 [ (Register 0 [Zero]), (Register 0 [One]) ]
--newRegister x = QuantumRegister x [

--sauliX :: Qubit -> Qubit
--sauliX (Qubit x) = Qubit (xgate #> x)
--                where xgate = (2><2)[0, 1, 1, 0] :: Matrix C
--
--sauliY :: Qubit -> Qubit
--sauliY (Qubit x) = Qubit (ygate #> x)
--                where ygate = (2><2)[0:+1, 0, 0, 0:+1] :: Matrix C
--
--sauliZ :: Qubit -> Qubit
--sauliZ (Qubit x) = Qubit (zgate #> x)
--                where zgate = (2><2)[1, 0, 0, -1] :: Matrix C

--data Bit = Zero | One deriving Eq
--
--instance Show Bit where
--    show Zero = "|0>"
--    show One  = "|1>"
--
--data Qubit a = Qubit (Complex a) (Complex a) deriving Show
--
--sauliX :: Qubit a -> Qubit a
--sauliX (Qubit x y) = Qubit y x
--
--sauliY :: (Fractional a, RealFloat a) => Qubit a -> Qubit a
--sauliY (Qubit x y) = Qubit rotY rotX
--        where i = 0 :+ 1
--              rotY = -y*i
--              rotX = x*i
--
--sauliZ :: (RealFloat a) => Qubit a -> Qubit a
--sauliZ (Qubit x y) = Qubit x (-y)

--data Qubit a = Qubit (Vector a)
--
---- Show the Qubit using Ket notation
--instance (Show a, Numeric a) => Show (Qubit a) where
--    show (Qubit x) = '(':(show first) ++ ")|0> + (" ++ (show second) ++ ")|1>"
--                    where first = (fromList [1, 0]) <.> x
--                          second = fromList [0, 1] <.> x
--
--notGate :: Qubit R -> Qubit R
--notGate (Qubit x) = let invertMatrix = (2><2) [-1, 0, 0, -1] in
--                        Qubit (invertMatrix #> x)

max_stars_repo_name: byronwasti/Quantum-Computer-Simulation

max_issues_repo_name: byronwasti/Quantum-Computer-Simulation

max_forks_repo_name: byronwasti/Quantum-Computer-Simulation


text:
{-# LANGUAGE RebindableSyntax, TypeSynonymInstances #-}
module DSLsofMath.W08 where
import Prelude hiding (Num(..),(/),(^),Fractional(..),Floating(..),sum)
import DSLsofMath.W05
import qualified DSLsofMath.W06
import DSLsofMath.W06 (Taylor, integ, sinx, sinf, cosx, cosf)
import DSLsofMath.Algebra
import Data.Complex

expx :: Field a => PowerSeries a
expx = integ 1 expx

expf :: Field a => a -> a
expf = evalPS 100 expx

i :: Ring a => Complex a
i = zero :+ one

ex1 :: Field a => Complex a
ex1 = expf i

compScale :: Ring a => a -> PowerSeries a -> PowerSeries a
compScale c (Poly as) = Poly (zipWith (*) as (iterate (c*) 1))

type PSC a = PowerSeries (Complex a)
expix :: Field a => PSC a
expix = compScale i expx

cosxisinx :: Field a => PSC a
cosxisinx = cosx + Poly [i] * sinx

ex2, ex2' :: Field a => PSC a
ex2   = takePoly 8 expix
ex2'  = takePoly 8 cosxisinx

test2 :: Bool
test2 = ex2 == (ex2' :: PSC Rational)

check2 :: Bool
check2 = ex2 == coeff2

coeff2 ::  PSC Rational
coeff2 =   Poly [      1            :+ 0, {-"\qquad"-}  0 :+     1,
                   (-  1  /  2)     :+ 0, {-"\qquad"-}  0 :+ (-  1  /  6),
                       1  /  24     :+ 0, {-"\qquad"-}  0 :+     1  /  120,
                   (-  1  /  720)   :+ 0, {-"\qquad"-}  0 :+ (-  1  /  5040)]

ex2R :: Poly Rational
ex2R = takePoly 8 cosx

ex2I :: Poly Rational
ex2I = takePoly 8 sinx

derivT :: Taylor a -> Taylor a
derivT = tail

integT :: a -> Taylor a -> Taylor a
integT = (:)

val ::  Additive a => Taylor a  ->  a
val (a:_)   =   a
val _       =   zero

expT, sinT, cosT :: Transcendental a => Taylor a -> Taylor a
expT  as  = integT  (exp  (val as))  (expT as   * derivT as)
sinT  as  = integT  (sin  (val as))  (cosT as   * derivT as)
cosT  as  = integT  (cos  (val as))  (-sinT as  * derivT as)

instance Transcendental a => Transcendental (Taylor a) where
   pi   =  [pi]; exp  =  expT;  sin  =  sinT;  cos  =  cosT

instance Field a => MulGroup (Taylor a) where
  recip = recipStream

recipStream :: Field a => Taylor a -> Taylor a
recipStream [] = error "recipStream: divByZero"
recipStream (f0:f') = g
  where  g   = g0:g'
         g0  = recip f0
         g'  = negate (f' * g*g)

expTx :: Taylor REAL
expTx = expT [0,1]
testExpT = take 5 expTx == [1.0, 1.0, 1.0, 1.0, 1.0]

expix3 :: Taylor (Complex Double)
expix3 = exp (i * x)            where  i  = [0 :+ 1]; x  = [0,1]

ex2alt3 = take 10 expix3
testex2alt3 = ex2alt3 ==  take 10 (concat (repeat [1, i, -1, -i]))

cosxisinx3 :: Taylor (Complex Double)
cosxisinx3 = cos x + i * sin x  where  i  = [0 :+ 1];  x  = [0,1]

ex2'alt3 = take 10 cosxisinx3

fs :: Field a => PowerSeries a
fs = integ 1 fs'
   where  fs'   = integ 0 fs''
          fs''  = exp3x + 3 * fs' - 2 * fs
exp3x :: Field a => PowerSeries a
exp3x = compScale 3 expx

max_stars_repo_name: Nexya/DSLsofMath

max_issues_repo_name: Nexya/DSLsofMath

max_forks_repo_name: Nexya/DSLsofMath


text:
module GApprox
  (
    GApprox (..)
  , createGApprox
  , predictG
  , updateG
  ) where

-- Wrapper for HNN's Neural network module
-- Using it for function approximation while in simulation -> wrapper supports creation,
-- prediction, and update.
-- Usecase: Predict 1 -> update 1 -> predict 1 -> update 1

-- Goal -> understand library enough to support a CCEA approach (ie, be able to mutate the
-- weights). It seems like there is a load from weight matrix function, so should involve just
-- creating a Network -> Weight matrix function.

import AI.HNN.FF.Network
import Numeric.LinearAlgebra
import Policy

data GApprox = GApprox (IO (Network Double))
instance Eq GApprox where
  (==) _ _ = True

predictG :: GApprox     -- Neural Network Approximating G
         -> [Double]    -- Input (will be state action pair)
         -> IO [Double] -- predicted value of G
predictG (GApprox network) input = do
  net <- network
  return $ toList $ output net sigmoid $ fromList input

updateG :: GApprox -- Neural Network Approximating G
        -> Double   -- Learning Rate
        -> [Double] -- Input to G
        -> [Double] -- Actual value of G
        -> GApprox -- Updated Neural Network
updateG (GApprox network) rate input target = GApprox newNet
  where newNet = do
          net <- network
          let sample = [ fromList input --> fromList target ] :: Samples Double
          return $ trainNTimes 1 rate sigmoid sigmoid' net sample

createGApprox :: GApprox
createGApprox = GApprox $ createNetwork 8 [14] 1

max_stars_repo_name: eklinkhammer/local-dpp

max_issues_repo_name: eklinkhammer/local-dpp

max_forks_repo_name: eklinkhammer/local-dpp


text:
import Numeric.LinearAlgebra
import Test.Hspec

import Lib
    ( forwardPropogate,
      sigmoid,
      weightsWithInitializer,
      runBatch,
      updateParameters,
      getLayer,
      ActivationFunction (..),
      Activation (..),
      Parameters,
      Gradients,
      Layer (..)
    )

main :: IO ()
main = hspec $ do
  describe "Lib.forwardPropogate" $ do
    it "correctly performs forward propogation" $ do
      let
        activationFunction = ActivationFunction { f=flip (/) 100, f'= \_ -> 1/100 }
        input    = (1><3) [1..]
        layers   = [
                    Layer{layerParameters=((3><4) [1..], fromList [1,1,1,1]),activationFunction=activationFunction},
                    Layer{layerParameters=((4><2) [1..], fromList [2,2]),activationFunction=activationFunction}
                   ]
        expected = [input, (1><4) [0.39,0.45,0.51,0.57], (1><2) [10.28 / 100, 12.2 / 100]] :: [Matrix Double]
        activations = forwardPropogate input layers
      map postActivation activations `shouldBe` expected
  describe "Lib.runBatch" $ do
    it "correctly backpropogates" $ do
      let
        input = (1><1) [1] :: Matrix Double
        expected = (1><1) [1]
        initialWeights = weightsWithInitializer 0.05 [1,1,1]
        initialBiases = map fromList [[0.05], [0.05]] :: [Vector Double]
        zippedInitialParameters = zip initialWeights initialBiases
        activationFunctions = [sigmoid,sigmoid]
        layers = zipWith getLayer zippedInitialParameters activationFunctions
        expectedGradients = [((1><1) [ -1.4970312464482186e-3 ], fromList [-1.4970312464482186e-3]),((1><1) [ -6.303013286946654e-2 ], fromList [-0.12006215555353811])]
        actualGradients = runBatch input expected layers
      actualGradients `shouldBe` expectedGradients
    describe "Lib.updateParameters" $ do
      it "correctly updates parameters" $ do
        let
          learningRate = 0.1
          regularizationTerm = 0.01
          parameters = [((1><2) [1,2], fromList [1,1])] :: [Parameters]
          gradients = [((1><2) [1,1], fromList [1,1])] :: [Gradients]
          expectedUpdatedParameters = [((1><2) [0.899, 1.899], fromList [0.9,0.9])] :: [Parameters]
          actualUpdatedParameters = updateParameters learningRate regularizationTerm gradients parameters
        actualUpdatedParameters `shouldBe` expectedUpdatedParameters

max_stars_repo_name: dmurphs/hsnet

max_issues_repo_name: dmurphs/hsnet

max_forks_repo_name: dmurphs/hsnet


text:
module Main where

import Prelude hiding (id, (.))
import Numeric.LinearAlgebra.Array
import Numeric.LinearAlgebra.Array.Util
import System.Random
import Control.Monad
import Control.Lens hiding ((#), para)

import CategoricDefinitions
import Autodiff.D
import Para
import Examples

main :: IO ()
main = run


text:
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Tests for the flat module
module Main where

import           Control.Monad
import           Data.Bits
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Short as SBS
import           Data.Char
import           Data.Either
import           Flat
import           Flat.Bits
import           Flat.Decoder
import qualified Flat.Encoder as E
import qualified Flat.Encoder.Prim as E
import qualified Flat.Encoder.Strict as E
import           Data.Int
import           Data.Proxy
import qualified Data.Sequence as Seq
import           Data.String (fromString)
import qualified Data.Text as T
import           Data.Word
import           Numeric.Natural
import           System.Exit
import           Test.Data
import           Test.Data.Arbitrary ()
import           Test.Data.Flat
import           Test.Data.Values hiding (lbs, ns)
import           Test.E
import           Test.E.Arbitrary ()
import           Test.E.Flat
import           Test.Tasty
import           Test.Tasty.HUnit
import           Test.Tasty.QuickCheck as QC hiding (getSize)
import           Flat.Endian
import           Data.FloatCast
import           Data.Text.Arbitrary
-- import Test.QuickCheck.Arbitrary
import qualified Data.Complex as B
import qualified Data.Ratio as B
import qualified Data.Map as C
import qualified Data.Map.Strict as CS
import qualified Data.Map.Lazy as CL
import qualified Data.IntMap.Strict as CS
import qualified Data.IntMap.Lazy as CL
-- import           Data.List
-- import           Data.Ord
#if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty as BI
#endif

instance Arbitrary UTF8Text where
  arbitrary = UTF8Text <$> arbitrary

  shrink t = UTF8Text <$> shrink (unUTF8 t)

#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)
instance Arbitrary UTF16Text where
  arbitrary = UTF16Text <$> arbitrary

  shrink t = UTF16Text <$> shrink (unUTF16 t)
#endif

-- instance Flat [Int16]
-- instance Flat [Word8]
-- instance Flat [Bool]
main = do
  -- #ifdef ghcjs_HOST_OS
  --   print "GHCJS"
  -- #endif
  -- printInfo
  -- print $ flat asciiStrT
  mainTest

  -- print $ flatRaw 18446744073709551615::Word64
  -- print $ B.unpack . flat $ (True,0::Word64,18446744073709551615::Word64)
  -- print (2^56::Word64,fromIntegral (1::Word8) `shiftL` 56 :: Word64,(18446744073709551615::Word64) `shiftR` 1)
  -- mainShow
  -- eWord64E id 0b
mainShow = do
  mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1 .. 10]
  exitFailure

mainTest = defaultMain tests

tests :: TestTree
tests = testGroup "Tests" [testPrimitives, testEncDec, testFlat]

testPrimitives =
  testGroup "conversion/memory primitives" [testEndian, testFloatingConvert]

  --,testShifts -- ghcjs fails this
testEncDec = testGroup
  "encode/decode primitives"
  [ testEncodingPrim
  , testDecodingPrim
#ifdef TEST_DECBITS
  , testDecBits
#endif
  ]

testFlat = testGroup
  "flat/unflat"
  [testSize, testLargeEnum, testContainers, flatUnflatRT, flatTests]

-- Flat.Endian tests (to run, need to modify imports and cabal file)
testEndian = testGroup
  "Endian"
  [ convBE toBE16 (2 ^ 10 + 3) (2 ^ 9 + 2 ^ 8 + 4)
  , convBE toBE32 (2 ^ 18 + 3) 50332672
  , convBE toBE64 (2 ^ 34 + 3) 216172782180892672
  , convBE toBE16 0x1234 0x3412
  , convBE toBE32 0x11223344 0x44332211
  , convBE toBE64 0x0123456789ABCDEF 0xEFCDAB8967452301]

testFloatingConvert = testGroup
  "Floating conversions"
  [ conv floatToWord (-0.15625) 3189768192
  , conv wordToFloat 3189768192 (-0.15625)
  , conv doubleToWord (-0.15625) 13818169556679524352
  , conv wordToDouble 13818169556679524352 (-0.15625)
  , rt "floatToWord" (prop_float_conv :: RT Float)
  , rt "doubleToWord" (prop_double_conv :: RT Double)]

convBE f v littleEndianE =
  let e = if isBigEndian
          then v
          else littleEndianE
  in testCase (unwords ["conv BigEndian", sshow v, "to", sshow e]) $ f v @?= e

conv f v e = testCase
  (unwords ["conv", sshow v, showB . flat $ v, "to", sshow e])
  $ f v @?= e

-- ghcjs bug on shiftR 0, see: https://github.com/ghcjs/ghcjs/issues/706
testShifts = testGroup "Shifts" $ map tst [0 .. 33]
  where
    tst n = testCase ("shiftR " ++ show n)
      $ let val = 4294967295 :: Word32
            s = val `shift` (-n)
            r = val `shiftR` n
        in r @?= s

-- shR = shiftR
-- shR = unsafeShiftR
shR val 0 = val
shR val n = shift val (-n)

testEncodingPrim = testGroup
  "Encoding Primitives"
  [ encRawWith 1 E.eTrueF [0b10000001]
  , encRawWith 3 (E.eTrueF >=> E.eFalseF >=> E.eTrueF) [0b10100001]
    -- Depends on endianess
    --,encRawWith 32 (E.eWord32E id $ 2^18 + 3) [3,0,4,0,1]
    -- ,encRawWith 64 (E.eWord64E id $ 0x1122334455667788) [0x88,0x77,0x66,0x55,0x44,0x33,0x22,0x11,1]
    --,encRawWith 65 (E.eTrueF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,128,129]
    --,encRawWith 65 (E.eFalseF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,0,129]
    -- Big Endian
  , encRawWith 32 (E.eWord32BEF $ 2 ^ 18 + 3) [0, 4, 0, 3, 1]
  , encRawWith 64 (E.eWord64BEF $ 2 ^ 34 + 3) [0, 0, 0, 4, 0, 0, 0, 3, 1]
  , encRawWith
      65
      (E.eTrueF >=> E.eWord64BEF (2 ^ 34 + 3))
      [128, 0, 0, 2, 0, 0, 0, 1, 129]
  , encRawWith
      65
      (E.eFalseF >=> E.eWord64BEF (2 ^ 34 + 3))
      [0, 0, 0, 2, 0, 0, 0, 1, 129]]
  where
    encRawWith sz enc exp = testCase
      (unwords ["encode raw with size", show sz])
      $ flatRawWith sz enc @?= exp

testDecodingPrim = testGroup
  "Decoding Primitives"
  [ dec
      ((,,,) <$> dropBits 13 <*> dBool <*> dBool <*> dBool)
      [0b10111110, 0b10011010]
      ((), False, True, False)
  , dec
      ((,,,) <$> dropBits 1 <*> dBE16 <*> dBool <*> dropBits 6)
      [0b11000000, 0b00000001, 0b01000000]
      ((), 2 ^ 15 + 2, True, ())
  , dec
      ((,,,) <$> dropBits 1 <*> dBE32 <*> dBool <*> dropBits 6)
      [0b11000000, 0b00000000, 0b00000000, 0b00000001, 0b01000000]
      ((), 2 ^ 31 + 2, True, ())
  , dec
      dBE64
      [ 0b10000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000010]
      (2 ^ 63 + 2)
  , dec
      ((,,,) <$> dropBits 1 <*> dBE64 <*> dBool <*> dropBits 6)
      [ 0b11000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000000
      , 0b00000001
      , 0b01000000]
      ((), 2 ^ 63 + 2, True, ())]
  where
    dec decOp v e = testCase (unwords ["decode", sshow v])
      $ unflatRawWith decOp (B.pack v) @?= Right e

testDecBits = testGroup "Decode Bits"
  $ concat
    [ decBitsN dBEBits8
    , decBitsN dBEBits16
    , decBitsN dBEBits32
    , decBitsN dBEBits64]
-- Test dBEBits8/16/32/64, extraction of up to 8/16/32/bits from various positions
  where
    decBitsN :: forall a.
             (Num a, FiniteBits a, Show a, Flat a)
             => (Int -> Get a)
             -> [TestTree]
    decBitsN dec = let s = finiteBitSize (undefined :: a)
                   in [decBits_ dec val numBitsToTake pre
                      | numBitsToTake <- [0 .. s]
                      , val <- [ 0 :: a
                               , 1 + 2 ^ (s - 2) + 2 ^ (s - 5)
                               , fromIntegral $ (2 ^ s :: Integer) - 1]
                      , pre <- [0, 1, 7]]

    decBits_ :: forall a.
             (FiniteBits a, Show a, Flat a)
             => (Int -> Get a)
             -> a
             -> Int
             -> Int
             -> TestTree
    decBits_ deco val numBitsToTake pre =
      -- a sequence composed by pre zero bits followed by the val and zero bits till the next byte boundary
      let vs = B.pack . asBytes . fromBools
            $ replicate pre False ++ toBools (asBits val)
          len = B.length vs
          sz = finiteBitSize (undefined :: a)
          dec :: Get a
          dec = do
            dropBits pre
            r <- deco numBitsToTake
            dropBits (len * 8 - numBitsToTake - pre)
            return r
          -- we expect the first numBitsToTake bits of the value
          expectedD @ (Right expected) :: Decoded a = Right
            $ val `shR` (sz - numBitsToTake) -- ghcjs: shiftR fails, see: https://github.com/ghcjs/ghcjs/issues/706
          actualD @ (Right actual) :: Decoded a = unflatRawWith dec vs
      in testCase
           (unwords
              [ "take"
              , show numBitsToTake
              , "bits from"
              , show val
              , "of size"
              , show sz
              , "with prefix"
              , show pre
              , "sequence"
              , showB vs
              , show expected
              , show actual
              , show $ val == actual
              , show $ expected == actual
              , show $ expected /= actual
              , show $ show expected == show actual
              , show $ flat expected == flat actual])
         $ actualD @?= expectedD

testSize = testGroup "Size"
  $ concat
    [ sz () 0
    , sz True 1
    , sz One 2
    , sz Two 2
    , sz Three 2
    , sz Four 3
    , sz Five 3
    , sz 'a' 8
    , sz 'à' 16
    , sz '经' 24
    , sz (0 :: Word8) 8
    , sz (1 :: Word8) 8
    , concatMap (uncurry sz) ns
    , concatMap (uncurry sz) nsI
    , concatMap (uncurry sz) nsII
    , sz (1.1 :: Float) 32
    , sz (1.1 :: Double) 64
    , sz "" 1
    , sz "abc" (4 + 3 * 8)
    , sz ((), (), Unit) 0
    , sz (True, False, One, Five) 7
    , sz map1 7
    , sz bs (4 + 3 * 8)
    , sz stBS bsSize
    , sz lzBS bsSize
#ifndef ghcjs_HOST_OS
    , sz shBS bsSize
#endif
    , sz tx utf8Size
    , sz (UTF8Text tx) utf8Size
#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)
    , sz (UTF16Text tx) utf16Size
#endif
    ]
  where
    tx = T.pack "txt"

    utf8Size = 8 + 8 + 3 * 32 + 8

    utf16Size = 8 + 8 + 3 * 16 + 8

    bsSize = 8 + 8 + 3 * 8 + 8

sz v e = [testCase (unwords ["size of", sshow v]) $ getSize v @?= e]

-- E258_256 = 11111110 _257 = 111111110 _258 = 111111111
testLargeEnum = testGroup "test enum with more than 256 constructors"
  $ concat
    [
#ifdef ENUM_LARGE
      sz E258_256 8
    , sz E258_257 9
    , sz E258_258 9
      -- As encodes are inlined, this is going to take for ever if this is compiled with -O1 or -O2
      -- , encRaw (E258_256) [0b11111110]
      -- , encRaw (E258_257) [0b11111111,0b00000000]
      -- , encRaw (E258_258) [0b11111111,0b10000000]
      -- , encRaw (E258_256,E258_257,E258_258) [0b11111110,0b11111111,0b01111111,0b11000000]
    , map trip [E258_1, E258_256, E258_257, E258_258]
    , map trip [E256_1, E256_134, E256_256]
#endif
    ]

testContainers =
  testGroup "containers" [trip longSeq, trip dataMap, trip listMap]

    -- , trip intMap
flatUnflatRT = testGroup
  "unflat (flat v) == v"
  [ rt "()" (prop_Flat_roundtrip :: RT ())
  , rt "Bool" (prop_Flat_roundtrip :: RT Bool)
  , rt "Char" (prop_Flat_roundtrip :: RT Char)
  , rt "Complex" (prop_Flat_roundtrip :: RT (B.Complex Float))
  , rt "Either N Bool" (prop_Flat_roundtrip :: RT (Either N Bool))
  , rt "Either Int Char" (prop_Flat_roundtrip :: RT (Either Int Char))
  , rt "Int8" (prop_Flat_Large_roundtrip :: RTL Int8)
  , rt "Int16" (prop_Flat_Large_roundtrip :: RTL Int16)
  , rt "Int32" (prop_Flat_Large_roundtrip :: RTL Int32)
  , rt "Int64" (prop_Flat_Large_roundtrip :: RTL Int64)
  , rt "Int" (prop_Flat_Large_roundtrip :: RTL Int)
  , rt "[Int16]" (prop_Flat_roundtrip :: RT [Int16])
  , rt "String" (prop_Flat_roundtrip :: RT String)
#if MIN_VERSION_base(4,9,0)
  , rt "NonEmpty" (prop_Flat_roundtrip :: RT (BI.NonEmpty Bool))
#endif
  , rt "Maybe N" (prop_Flat_roundtrip :: RT (Maybe N))
  , rt "Ratio" (prop_Flat_roundtrip :: RT (B.Ratio Int32))
  , rt "Word8" (prop_Flat_Large_roundtrip :: RTL Word8)
  , rt "Word16" (prop_Flat_Large_roundtrip :: RTL Word16)
  , rt "Word32" (prop_Flat_Large_roundtrip :: RTL Word32)
  , rt "Word64" (prop_Flat_Large_roundtrip :: RTL Word64)
  , rt "Word" (prop_Flat_Large_roundtrip :: RTL Word)
  , rt "Natural" (prop_Flat_roundtrip :: RT Natural)
  , rt "Integer" (prop_Flat_roundtrip :: RT Integer)
  , rt "Float" (prop_Flat_roundtrip :: RT Float)
  , rt "Double" (prop_Flat_roundtrip :: RT Double)
  , rt "Text" (prop_Flat_roundtrip :: RT T.Text)
  , rt "UTF8 Text" (prop_Flat_roundtrip :: RT UTF8Text)
#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)
  , rt "UTF16 Text" (prop_Flat_roundtrip :: RT UTF16Text)
#endif
  , rt "ByteString" (prop_Flat_roundtrip :: RT B.ByteString)
  , rt "Lazy ByteString" (prop_Flat_roundtrip :: RT L.ByteString)
#ifndef ghcjs_HOST_OS
  , rt "Short ByteString" (prop_Flat_roundtrip :: RT SBS.ShortByteString)
#endif
  , rt "Map.Strict" (prop_Flat_roundtrip :: RT (CS.Map Int Bool))
  , rt "Map.Lazy" (prop_Flat_roundtrip :: RT (CL.Map Int Bool))
  , rt "IntMap.Strict" (prop_Flat_roundtrip :: RT (CS.IntMap Bool))
  , rt "IntMap.Lazy" (prop_Flat_roundtrip :: RT (CL.IntMap Bool))
  , rt "Unit" (prop_Flat_roundtrip :: RT Unit)
  , rt "Un" (prop_Flat_roundtrip :: RT Un)
  , rt "N" (prop_Flat_roundtrip :: RT N)
  , rt "E2" (prop_Flat_roundtrip :: RT E2)
  , rt "E3" (prop_Flat_roundtrip :: RT E3)
  , rt "E4" (prop_Flat_roundtrip :: RT E4)
  , rt "E8" (prop_Flat_roundtrip :: RT E8)
  , rt "E16" (prop_Flat_roundtrip :: RT E16)
  , rt "E17" (prop_Flat_roundtrip :: RT E17)
  , rt "E32" (prop_Flat_roundtrip :: RT E32)
  , rt "A" (prop_Flat_roundtrip :: RT A)
  , rt "B" (prop_Flat_roundtrip :: RT B)
    -- ,rt "Tree Bool" (prop_Flat_roundtrip:: RT (Tree Bool))
    -- ,rt "Tree N" (prop_Flat_roundtrip:: RT (Tree N))
  , rt "List N" (prop_Flat_roundtrip :: RT (List N))]

rt n = QC.testProperty (unwords ["round trip", n])

flatTests = testGroup "flat/unflat Unit tests"
  $ concat
    [ -- Expected errors
      errDec (Proxy :: Proxy Bool) [] -- no data
    , errDec (Proxy :: Proxy Bool) [128] -- no filler
    , errDec (Proxy :: Proxy Bool) [128 + 1, 1, 2, 4, 8] -- additional bytes
    , errDec (Proxy :: Proxy Text) (B.unpack (flat ((fromString "\x80") :: B.ByteString))) -- invalid UTF-8
    , encRaw () []
    , encRaw ((), (), Unit) []
    , encRaw (Unit, 'a', Unit, 'a', Unit, 'a', Unit) [97, 97, 97]
    , a () [1]
    , a True [128 + 1]
    , a (True, True) [128 + 64 + 1]
    , a (True, False, True) [128 + 32 + 1]
    , a (True, False, True, True) [128 + 32 + 16 + 1]
    , a (True, False, True, True, True) [128 + 32 + 16 + 8 + 1]
    , a (True, False, True, True, True, True) [128 + 32 + 16 + 8 + 4 + 1]
    , a
        (True, False, True, True, True, True, True)
        [128 + 32 + 16 + 8 + 4 + 2 + 1]
    , a
        (True, False, True, True, (True, True, True, True))
        [128 + 32 + 16 + 8 + 4 + 2 + 1, 1]
    , encRaw (True, False, True, True) [128 + 32 + 16]
    , encRaw
        ( (True, True, False, True, False)
        , (False, False, True, False, True, True))
        [128 + 64 + 16 + 1, 64 + 32]
    , encRaw ('\0', '\1', '\127') [0, 1, 127]
    , encRaw (33 :: Word32, 44 :: Word32) [33, 44]
       --,s (Elem True) [64]
       --,s (NECons True (NECons False (Elem True))) [128+64+32+4]
    , encRaw (0 :: Word8) [0]
    , encRaw (1 :: Word8) [1]
    , encRaw (255 :: Word8) [255]
    , encRaw (0 :: Word16) [0]
    , encRaw (1 :: Word16) [1]
    , encRaw (255 :: Word16) [255, 1]
    , encRaw (256 :: Word16) [128, 2]
    , encRaw (65535 :: Word16) [255, 255, 3]
    , encRaw (127 :: Word32) [127]
    , encRaw (128 :: Word32) [128, 1]
    , encRaw (129 :: Word32) [129, 1]
    , encRaw (255 :: Word32) [255, 1]
    , encRaw (16383 :: Word32) [255, 127]
    , encRaw (16384 :: Word32) [128, 128, 1]
    , encRaw (16385 :: Word32) [129, 128, 1]
    , encRaw (32767 :: Word32) [255, 255, 1]
    , encRaw (32768 :: Word32) [128, 128, 2]
    , encRaw (32769 :: Word32) [129, 128, 2]
    , encRaw (65535 :: Word32) [255, 255, 3]
    , encRaw (2097151 :: Word32) [255, 255, 127]
    , encRaw (2097152 :: Word32) [128, 128, 128, 1]
    , encRaw (2097153 :: Word32) [129, 128, 128, 1]
    , encRaw (4294967295 :: Word32) [255, 255, 255, 255, 15]
    , encRaw (255 :: Word64) [255, 1]
    , encRaw (65535 :: Word64) [255, 255, 3]
    , encRaw (4294967295 :: Word64) [255, 255, 255, 255, 15]
    , encRaw
        (18446744073709551615 :: Word64)
        [255, 255, 255, 255, 255, 255, 255, 255, 255, 1]
    , encRaw
        (False, 18446744073709551615 :: Word64)
        [127, 255, 255, 255, 255, 255, 255, 255, 255, 128, 128]
    , encRaw (255 :: Word) [255, 1]
    , encRaw (65535 :: Word) [255, 255, 3]
    , encRaw (4294967295 :: Word) [255, 255, 255, 255, 15]
    , tstI [0 :: Int8, 2, -2]
    , encRaw (127 :: Int8) [254]
    , encRaw (-128 :: Int8) [255]
    , tstI [0 :: Int16, 2, -2, 127, -128]
    , tstI [0 :: Int32, 2, -2, 127, -128]
    , tstI [0 :: Int64, 2, -2, 127, -128]
    , encRaw (-1024 :: Int64) [255, 15]
    , encRaw (maxBound :: Word8) [255]
    , encRaw (True, maxBound :: Word8) [255, 128]
    , encRaw (maxBound :: Word16) [255, 255, 3]
    , encRaw (True, maxBound :: Word16) [255, 255, 129, 128]
    , encRaw (maxBound :: Word32) [255, 255, 255, 255, 15]
    , encRaw (True, maxBound :: Word32) [255, 255, 255, 255, 135, 128]
    , encRaw
        (maxBound :: Word64)
        [255, 255, 255, 255, 255, 255, 255, 255, 255, 1]
    , encRaw
        (True, maxBound :: Word64)
        [255, 255, 255, 255, 255, 255, 255, 255, 255, 128, 128]
    , encRaw
        (minBound :: Int64)
        [255, 255, 255, 255, 255, 255, 255, 255, 255, 1]
    , encRaw
        (maxBound :: Int64)
        [254, 255, 255, 255, 255, 255, 255, 255, 255, 1]
    , tstI [0 :: Int, 2, -2, 127, -128]
    , tstI [0 :: Integer, 2, -2, 127, -128, -256, -512]
    , encRaw (-1024 :: Integer) [255, 15]
    , encRaw (0 :: Float) [0, 0, 0, 0]
    , encRaw (-2 :: Float) [0b11000000, 0, 0, 0]
    , encRaw (0.085 :: Float) [0b00111101, 0b10101110, 0b00010100, 0b01111011]
    , encRaw (0 :: Double) [0, 0, 0, 0, 0, 0, 0, 0]
    , encRaw (-2 :: Double) [0b11000000, 0, 0, 0, 0, 0, 0, 0]
    , encRaw (23 :: Double) [0b01000000, 0b00110111, 0, 0, 0, 0, 0, 0]
    , encRaw (-0.15625 :: Float) [0b10111110, 0b00100000, 0, 0]
    , encRaw (-0.15625 :: Double) [0b10111111, 0b11000100, 0, 0, 0, 0, 0, 0]
    , encRaw
        (-123.2325E-23 :: Double)
        [ 0b10111011
        , 0b10010111
        , 0b01000111
        , 0b00101000
        , 0b01110101
        , 0b01111011
        , 0b01000111
        , 0b10111010]
    , encRaw (Left True :: Either Bool (Double, Double)) [0b01000000]
    , encRaw (-2.1234E15 :: Double) [195, 30, 44, 226, 90, 221, 64, 0]
    , encRaw (1.1234E-22 :: Double) [59, 96, 249, 241, 120, 219, 249, 174]
    , encRaw
        ((False, -2.1234E15) :: (Bool, Double))
        [97, 143, 22, 113, 45, 110, 160, 0, 0]
    , encRaw
        ((True, -2.1234E15) :: (Bool, Double))
        [225, 143, 22, 113, 45, 110, 160, 0, 0]
    , encRaw ((-2.1234E15, 1.1234E-22) :: (Double, Double))
        $ [0b11000011, 30, 44, 226, 90, 221, 64, 0]
        ++ [59, 96, 249, 241, 120, 219, 249, 174]
    , encRaw
        ((True, -2.1234E15, 1.1234E-22) :: (Bool, Double, Double))
        [ 0b11100001
        , 143
        , 22
        , 113
        , 45
        , 110
        , 160
        , 0
        , 29
        , 176
        , 124
        , 248
        , 188
        , 109
        , 252
        , 215
        , 0]
    , encRaw
        (Right (-2.1234E15, 1.1234E-22) :: Either Bool (Double, Double))
        [ 0b11100001
        , 143
        , 22
        , 113
        , 45
        , 110
        , 160
        , 0
        , 29
        , 176
        , 124
        , 248
        , 188
        , 109
        , 252
        , 215
        , 0]
    , encRaw (Left True :: Either Bool Direction) [0b01000000]
    , encRaw (Right West :: Either Bool Direction) [0b11110000]
    , map trip [minBound, maxBound :: Word8]
    , map trip [minBound, maxBound :: Word16]
    , map trip [minBound, maxBound :: Word32]
    , map trip [minBound, maxBound :: Word64]
    , map trip [minBound :: Int8, maxBound :: Int8]
    , map trip [minBound :: Int16, maxBound :: Int16]
    , map trip [minBound :: Int32, maxBound :: Int32]
    , map trip [minBound :: Int64, maxBound :: Int64]
    , map tripShow [0 :: Float, -0 :: Float, 0 / 0 :: Float, 1 / 0 :: Float]
    , map
        tripShow
        [0 :: Double, -0 :: Double, 0 / 0 :: Double, 1 / 0 :: Double]
    , encRaw '\0' [0]
    , encRaw '\1' [1]
    , encRaw '\127' [127]
    , encRaw 'a' [97]
    , encRaw 'à' [224, 1]
    , encRaw '经' [207, 253, 1]
    , [trip [chr 0x10FFFF]]
    , encRaw Unit []
    , encRaw (Un False) [0]
    , encRaw (One, Two, Three) [16 + 8]
    , encRaw (Five, Five, Five) [255, 128]
       --,s (NECons True (Elem True)) [128+64+16]
    , encRaw "" [0]
#ifdef LIST_BIT
    , encRaw "abc" [176, 216, 172, 96]
    , encRaw [False, True, False, True] [128 + 32 + 16 + 8 + 2 + 1, 0]
#elif defined(LIST_BYTE)
    , s "abc" s3
    , s (cs 600) s600
#endif
       -- Aligned structures
       --,s (T.pack "") [1,0]
       --,s (Just $ T.pack "abc") [128+1,3,97,98,99,0]
       --,s (T.pack "abc") (al s3)
       --,s (T.pack $ cs 600) (al s600)
    , encRaw map1 [0b10111000]
    , encRaw (B.pack $ csb 3) (bsl c3)
    , encRaw (B.pack $ csb 600) (bsl s600)
    , encRaw (L.pack $ csb 3) (bsl c3)
      -- Long LazyStrings can have internal sections shorter than 255
      --,s (L.pack $ csb 600) (bsl s600)
    , [trip [1 .. 100 :: Int16]]
      -- See https://github.com/typelead/eta/issues/901
#ifndef ETA_VERSION
    , [trip longAsciiStrT]
    , [trip longBoolListT]
#endif
    , [trip asciiTextT]
    , [trip english]
    , [trip "维护和平正"]
    , [trip (T.pack "abc")]
    , [trip unicodeText]
    , [trip unicodeTextUTF8T]
    , [trip longBS, trip longLBS]
#ifndef ghcjs_HOST_OS
    , [trip longSBS]
#endif
#if! defined(ghcjs_HOST_OS) && ! defined (ETA_VERSION)
    , [trip unicodeTextUTF16T]
#endif
    ]
--al = (1:) -- prealign
  where
    bsl = id -- noalign

    tstI = map ti

    ti v
      | v >= 0 = testCase (unwords ["Int", show v])
        $ teq v (2 * fromIntegral v :: Word64)
      | otherwise = testCase (unwords ["Int", show v])
        $ teq v (2 * fromIntegral (-v) - 1 :: Word64)

    teq a b = ser a @?= ser b

            --,testCase (unwords ["unflat raw",sshow v]) $ desRaw e @?= Right v]
    -- Aligned values unflat to the original value, modulo the added filler.
    a v e = [ testCase (unwords ["flat", sshow v]) $ ser v @?= e
            , testCase (unwords ["unflat", sshow v])
                $ let Right v' = des e
                  in v @?= v']

      -- a v e = [testCase (unwords ["flat postAligned",show v]) $ ser (postAligned v) @?= e
      --         ,testCase (unwords ["unflat postAligned",show v]) $ let Right (PostAligned v' _) = des e in v @?= v']
encRaw :: forall a. (Show a, Flat a) => a -> [Word8] -> [TestTree]
encRaw v e =
  [ testCase (unwords ["flat raw", sshow v, show . B.unpack . flat $ v])
      $ serRaw v @?= e]

trip :: forall a. (Show a, Flat a, Eq a) => a -> TestTree
trip v = testCase (unwords ["roundtrip", sshow v])
  $
  -- direct comparison
  (unflat (flat v :: B.ByteString) :: Decoded a) @?= (Right v :: Decoded a)

tripShow :: forall a. (Show a, Flat a, Eq a) => a -> TestTree
tripShow v = testCase (unwords ["roundtrip", sshow v])
  $
  -- we use show to get Right NaN == Right NaN
  show (unflat (flat v :: B.ByteString) :: Decoded a)
  @?= show (Right v :: Decoded a)

-- Test Data
lzBS = L.pack bs

stBS = B.pack bs

bs = [32, 32, 32 :: Word8]

s3 = [3, 97, 98, 99, 0]

c3a = [3, 99, 99, 99, 0] -- Array Word8

c3 = pre c3a

s600 = pre s600a

pre = (1:)

s600a = concat [[255], csb 255, [255], csb 255, [90], csb 90, [0]]

s600B =
  concat [[55], csb 55, [255], csb 255, [90], csb 90, [200], csb 200, [0]]

longSeq :: Seq.Seq Word8
longSeq = Seq.fromList lbs

longBS = B.pack lbs

longLBS = L.concat $ concat $ replicate 10 [L.pack lbs]

lbs = concat $ replicate 100 [234, 123, 255, 0]

cs n = replicate n 'c' -- take n $ cycle ['a'..'z']

csb = map (fromIntegral . ord) . cs

map1 = C.fromList [(False, True), (True, False)]

ns :: [(Word64, Int)]
ns = [((-) (2 ^ (i * 7)) 1, fromIntegral (8 * i)) | i <- [1 .. 10]]

nsI :: [(Int64, Int)]
nsI = nsI_

nsII :: [(Integer, Int)]
nsII = nsI_

nsI_ = [((-) (2 ^ (((-) i 1) * 7)) 1, fromIntegral (8 * i)) | i <- [1 .. 10]]

#ifndef ghcjs_HOST_OS
shBS = SBS.toShort stBS

longSBS = SBS.toShort longBS
#endif

sshow = take 80 . show

showB = show . B.unpack

errDec :: forall a. (Flat a, Eq a, Show a) => Proxy a -> [Word8] -> [TestTree]

--errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in ev @?= Left ""]
errDec _ bs = [ testCase "bad decode"
                  $ let ev = (des bs :: Decoded a)
                    in isRight ev @?= False]

ser :: Flat a => a -> [Word8]
ser = B.unpack . flat

des :: Flat a => [Word8] -> Decoded a
des = unflat

flatRawWith sz enc = B.unpack
  $ E.strictEncoder (sz + 8) (E.Encoding $ enc >=> E.eFillerF)

serRaw :: Flat a => a -> [Word8]

-- serRaw = B.unpack . flatRaw
-- serRaw = L.unpack . flatRaw
serRaw = asBytes . bits

--desRaw :: Flat a => [Word8] -> Decoded a
--desRaw = unflatRaw . L.pack
type RT a = a -> Bool

type RTL a = Large a -> Bool

prop_Flat_roundtrip :: (Flat a, Eq a) => a -> Bool
prop_Flat_roundtrip = roundTripExt

prop_Flat_Large_roundtrip :: (Eq b, Flat b) => Large b -> Bool
prop_Flat_Large_roundtrip (Large x) = roundTripExt x

roundTrip x = unflat (flat x :: B.ByteString) == Right x

-- Test roundtrip for both the value and the value embedded between bools
roundTripExt x = roundTrip x && roundTrip (True, x, False)

prop_double_conv d = wordToDouble (doubleToWord d) == d

prop_float_conv d = wordToFloat (floatToWord d) == d
{-
prop_common_unsigned :: (Num l,Num h,Flat l,Flat h) => l -> h -> Bool
prop_common_unsigned n _ = let n2 :: h = fromIntegral n
                           in flat n == flat n2
-}
-- e :: Stream Bool
-- e = unflatIncremental . flat $ stream1
-- el :: List Bool
-- el = unflatIncremental . flat $ infList
-- deflat = unflat
-- b1 :: BLOB UTF8
-- b1 = BLOB UTF8 (preAligned (List255 [97,98,99]))
-- -- b1 = BLOB (preAligned (UTF8 (List255 [97,98,99])))

max_stars_repo_name: michaelpj/flat

max_issues_repo_name: michaelpj/flat

max_forks_repo_name: michaelpj/flat


text:
{-# LANGUAGE BangPatterns, CPP, FlexibleContexts, Rank2Types #-}
#if __GLASGOW_HASKELL__ >= 704
{-# OPTIONS_GHC -fsimpl-tick-factor=200 #-}
#endif

-- |
-- Module    : Statistics.Function
-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Useful functions.

module Statistics.Function
    (
    -- * Scanning
      minMax
    -- * Sorting
    , sort
    , gsort
    , sortBy
    , partialSort
    -- * Indexing
    , indexed
    , indices
    -- * Bit twiddling
    , nextHighestPowerOfTwo
    -- * Comparison
    , within
    -- * Arithmetic
    , square
    -- * Vectors
    , unsafeModify
    -- * Combinators
    , for
    , rfor
    ) where

#include "MachDeps.h"

import Control.Monad.ST (ST)
import Data.Bits ((.|.), shiftR)
import qualified Data.Vector.Algorithms.Intro as I
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as M
import Statistics.Function.Comparison (within)

-- | Sort a vector.
sort :: U.Vector Double -> U.Vector Double
sort = G.modify I.sort
{-# NOINLINE sort #-}

-- | Sort a vector.
gsort :: (Ord e, G.Vector v e) => v e -> v e
gsort = G.modify I.sort
{-# INLINE gsort #-}

-- | Sort a vector using a custom ordering.
sortBy :: (G.Vector v e) => I.Comparison e -> v e -> v e
sortBy f = G.modify $ I.sortBy f
{-# INLINE sortBy #-}

-- | Partially sort a vector, such that the least /k/ elements will be
-- at the front.
partialSort :: (G.Vector v e, Ord e) =>
               Int -- ^ The number /k/ of least elements.
            -> v e
            -> v e
partialSort k = G.modify (`I.partialSort` k)
{-# SPECIALIZE partialSort :: Int -> U.Vector Double -> U.Vector Double #-}

-- | Return the indices of a vector.
indices :: (G.Vector v a, G.Vector v Int) => v a -> v Int
indices a = G.enumFromTo 0 (G.length a - 1)
{-# INLINE indices #-}

-- | Zip a vector with its indices.
indexed :: (G.Vector v e, G.Vector v Int, G.Vector v (Int,e)) => v e -> v (Int,e)
indexed a = G.zip (indices a) a
{-# INLINE indexed #-}

data MM = MM {-# UNPACK #-} !Double {-# UNPACK #-} !Double

-- | Compute the minimum and maximum of a vector in one pass.
minMax :: (G.Vector v Double) => v Double -> (Double, Double)
minMax = fini . G.foldl' go (MM (1/0) (-1/0))
  where
    go (MM lo hi) k = MM (min lo k) (max hi k)
    fini (MM lo hi) = (lo, hi)
{-# INLINE minMax #-}

-- | Efficiently compute the next highest power of two for a
-- non-negative integer.  If the given value is already a power of
-- two, it is returned unchanged.  If negative, zero is returned.
nextHighestPowerOfTwo :: Int -> Int
nextHighestPowerOfTwo n
#if WORD_SIZE_IN_BITS == 64
  = 1 + _i32
#else
  = 1 + i16
#endif
  where
    i0   = n - 1
    i1   = i0  .|. i0  `shiftR` 1
    i2   = i1  .|. i1  `shiftR` 2
    i4   = i2  .|. i2  `shiftR` 4
    i8   = i4  .|. i4  `shiftR` 8
    i16  = i8  .|. i8  `shiftR` 16
    _i32 = i16 .|. i16 `shiftR` 32
-- It could be implemented as
--
-- > nextHighestPowerOfTwo n = 1 + foldl' go (n-1) [1, 2, 4, 8, 16, 32]
--     where go m i = m .|. m `shiftR` i
--
-- But GHC do not inline foldl (probably because it's recursive) and
-- as result function walks list of boxed ints. Hand rolled version
-- uses unboxed arithmetic.

-- | Multiply a number by itself.
square :: Double -> Double
square x = x * x

-- | Simple for loop.  Counts from /start/ to /end/-1.
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for n0 !n f = loop n0
  where
    loop i | i == n    = return ()
           | otherwise = f i >> loop (i+1)
{-# INLINE for #-}

-- | Simple reverse-for loop.  Counts from /start/-1 to /end/ (which
-- must be less than /start/).
rfor :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
rfor n0 !n f = loop n0
  where
    loop i | i == n    = return ()
           | otherwise = let i' = i-1 in f i' >> loop i'
{-# INLINE rfor #-}

unsafeModify :: M.MVector s Double -> Int -> (Double -> Double) -> ST s ()
unsafeModify v i f = do
  k <- M.unsafeRead v i
  M.unsafeWrite v i (f k)
{-# INLINE unsafeModify #-}

max_stars_repo_name: StefanHubner/statistics

max_issues_repo_name: StefanHubner/statistics

max_forks_repo_name: StefanHubner/statistics


text:
{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds #-}

module GPLVM.GaussianProcess
       ( GaussianProcess (..)
       , GPTrainingData (..)
       , PosteriorSample (..)
       , gpToPosteriorSample
       , kernelGP
       ) where

import Universum hiding (transpose, Vector)

import Control.Lens (makeLenses)

import Data.Array.Repa
import Data.Array.Repa.Repr.Unboxed (Unbox)
import Numeric.LinearAlgebra.Repa hiding (Matrix, Vector)
import System.Random (Random, RandomGen, mkStdGen)

import GPLVM.Types (InputObservations(..), Matrix, Vector, unInputObs)
import GPLVM.Util

data GaussianProcess a = GaussianProcess
    { -- | we define gaussian process by some kernel function
      _kernelGP :: Vector D a -> Vector D a -> Matrix D a
    }

data GPTrainingData a = GPTrainingData
    { _inputTrain  :: Vector D a  -- ^ input training data
    , _outputTrain :: Vector D a  -- ^ output training data
    }

makeLenses ''GaussianProcess
makeLenses ''GPTrainingData

newtype PosteriorSample a = PosteriorSample
    { unSample :: Matrix D a  -- ^ posterior sample
    }

-- | Constraint kind required to getting a posterior sample by a given GP
type GPConstraint a =
  ( Field a
  , Random a
  , Unbox a
  , Floating a
  , Eq a
  )

-- | Main GP function: get a posterior sample by some kernel function, input observations and training data

gpToPosteriorSample
  :: forall a g.
  GPConstraint a
  => InputObservations a        -- ^ input observations
  -> GaussianProcess a          -- ^ kernel function
  -> GPTrainingData a           -- ^ training data
  -> Int                        -- ^ number of samples
  -> Maybe (PosteriorSample a)  -- ^ posterior functional prior
gpToPosteriorSample (InputObservations observe@(ADelayed (Z :. len) _)) gP trainingData sampleNumber = do
  -- | kernel applied to input test points (so-called K_ss)
  let covarianceMatrix = kernel observe observe

  -- | kernel applied to input training points (so-called K)
  let trainingKernel = kernel inputTrain' inputTrain'

  -- | Cholesky decomposition applied to kernel of training points (:), so-called L
  let cholK = cholSH $ trainingKernel +^
                (smap (* 0.00005) . identD . size . extent $ inputTrain')

  -- | covariance between test points and input training points (so-called K_s)
  let testPointMean = kernel observe inputTrain'

  -- | (roots of L * x = K_s)
  cholKSolve <- delay <$> linearSolveS cholK testPointMean

  -- | solve linear system for output training points
  cholKSolveOut <- delay <$> linearSolveS cholK (transposeMatrix $ toMatrix outputTrain' len)

  -- | compute mean
  let mean = (transposeMatrix cholKSolveOut) `mulD` cholKSolve

  -- | posterior
  let postF' = cholSH $
                     covarianceMatrix +^
                     ((smap (* 1.0e-6) (identD len)) -^
                     (transposeMatrix cholKSolve) `mulD` cholKSolve)

  -- | posterior sample
  return $ (PosteriorSample $ mean +^ (functionalPrior postF' (mkStdGen 1) sampleNumber))
    where
       kernel = gP ^. kernelGP
       inputTrain' = trainingData ^. inputTrain
       outputTrain' = trainingData ^. outputTrain
       mulD m n = delay $ m `mulS` n
       functionalPrior matrix@(ADelayed (Z :. rows :. cols) _) gen sampleNumber =
         delay $ matrix `mulS` randomCoeffs
         where
           randomCoeffs = randomMatrixD (mkStdGen (-4)) (rows, sampleNumber)

max_stars_repo_name: serokell/GPLVMHaskell

max_issues_repo_name: serokell/GPLVMHaskell

max_forks_repo_name: serokell/GPLVMHaskell


text:
module Generators
  (
  -- * Molecular Generators
    generateOneMolecule
  , generateManyMolecules
  ) where

import Control.Lens
import System.Directory
import DistanceGeometry
import ReadWrite
import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Data
import Types

generateOneMolecule ::
     FilePath -- ^ Input directory
  -> FilePath -- ^ Output dorectory
  -> FilePath -- ^ Molecule
  -> Double -- ^ Error
  -> IO ()
generateOneMolecule idir odir mol err = generateManyMolecules idir odir mol err 1

generateManyMolecules ::
     FilePath -- ^ Input directory
  -> FilePath -- ^ Output directory
  -> FilePath -- ^ Molecule
  -> Double -- ^ Error
  -> Int -- ^ The number of molecules generated
  -> IO ()
generateManyMolecules idir odir mol err n = do
  let odir' = odir ++ "/" ++ mol
  doesPathExist odir' >>= (`createDirectoryIfMissing` odir')
  step odir' 1
  where
    step odir s
      | s > n = return ()
      | otherwise = do
        let (atoms, bonds) = readMolV2000 (idir ++ "/" ++ mol ++ ".mol")
        let s0@(u, l) = (triangleSmooth . generateDistBoundsMatr atoms) bonds
        s1 <- randomDistMatr s0
        let s2 = (generateCoorFromEigValVec . largestEigValVec . distMatrToMetricMatr) s1
        let derr = distanceErrorFunction s2 u l bonds
            cerr = chiralErrorFunction s2 u l bonds
        if derr + cerr > err
          then step odir s
          else do
            -- Write result molecule in output files
            let newmole = updateCoord s2 atoms
            writeXYZ (odir ++ "/" ++ mol ++ "-" ++ show s ++ ".xyz") "Comment" newmole

            -- Write logs in output files
            let logs =
                 show newmole ++ "\n" ++
                 "Distance error = " ++ show derr ++ "\n" ++
                 "Chiral error = " ++ show cerr ++ "\n"
            writeFile (odir ++ "/" ++ mol ++ "-" ++ show s ++ ".log") logs

            -- Print to console
            putStrLn ("generateManyMolecules: " ++ mol ++ ": step " ++ show s ++ ": OK!")
            step odir (s+1)

max_stars_repo_name: wurthel/distance-geometry

max_issues_repo_name: wurthel/distance-geometry

max_forks_repo_name: wurthel/distance-geometry


text:
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-|
Module      : Grenade.Layers.Gelu
Description : Gaussian Error Linear Unit (GELU)
Copyright   : (c) Manuel Schneckenreither, 2020
License     : BSD2
Stability   : experimental

This module implements the Gaussian Error Linear Unit (GELU) activiation function. See

Hendrycks, Dan, and Kevin Gimpel. "Gaussian error linear units (gelus)." arXiv preprint arXiv:1606.08415 (2016).

Available at: https://arxiv.org/pdf/1606.08415.pdf

As in the paper we simply let μ = 0 and σ = 1. Futher, we use the simplified and thus fast representation: x * sigmoid (1.702 * x)

-}
module Grenade.Layers.Gelu (
    Gelu (..)
  , SpecGelu (..)
  , specGelu1D
  , specGelu2D
  , specGelu3D
  , gelu
  ) where

import           Control.DeepSeq                (NFData (..))
import           Data.Constraint                (Dict (..))
import           Data.Reflection                (reifyNat)
import           Data.Serialize
import           Data.Singletons
import           GHC.Generics                   (Generic)
import           GHC.TypeLits
import qualified Numeric.LinearAlgebra.Static   as LAS
import           Unsafe.Coerce                  (unsafeCoerce)

import           Grenade.Core
import           Grenade.Dynamic
import           Grenade.Dynamic.Internal.Build

-- | A Gaussion Error Linear Unit.
--   A layer which can act between any shape of the same dimension, acting as a
--   diode on every neuron individually.
--
--   Hendrycks, Dan, and Kevin Gimpel. "Gaussian error linear units (gelus)." arXiv preprint arXiv:1606.08415 (2016).
data Gelu = Gelu
  deriving (Generic, NFData, Show)

instance UpdateLayer Gelu where
  type Gradient Gelu = ()
  runUpdate _ _ _ = Gelu

instance RandomLayer Gelu where
  createRandomWith _ _ = return Gelu

instance Serialize Gelu where
  put _ = return ()
  get = return Gelu

geluForwardFast :: Floating x => x -> x
geluForwardFast x = x / (e ** (-1.702 * x) + 1) -- = x * sigmoid (1.702 * x)
  where
    e = 2.71828

geluBackwardFast :: Floating x => x -> x
geluBackwardFast x = (e ** (1.702 * x) * (1 + e ** (1.702 * x) + 1.702 * x)) / (1 + e ** (1.702 * x)) ** 2
  where
    e = 2.71828

instance (KnownNat i) => Layer Gelu ('D1 i) ('D1 i) where
  type Tape Gelu ('D1 i) ('D1 i) = S ('D1 i)

  runForwards _ (S1D y) = (S1D y, S1D (gelu y))
    where
      gelu = LAS.dvmap geluForwardFast
  runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (gelu' y * dEdy))
    where
      gelu' = LAS.dvmap geluBackwardFast

instance (KnownNat i, KnownNat j) => Layer Gelu ('D2 i j) ('D2 i j) where
  type Tape Gelu ('D2 i j) ('D2 i j) = S ('D2 i j)

  runForwards _ (S2D y) = (S2D y, S2D (gelu y))
    where
      gelu = LAS.dmmap geluForwardFast
  runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (gelu' y * dEdy))
    where
      gelu' = LAS.dmmap geluBackwardFast

instance (KnownNat i, KnownNat j, KnownNat k) => Layer Gelu ('D3 i j k) ('D3 i j k) where

  type Tape Gelu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)

  runForwards _ (S3D y) = (S3D y, S3D (gelu y))
    where
      gelu = LAS.dmmap geluForwardFast
  runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (gelu' y * dEdy))
    where
      gelu' = LAS.dmmap geluBackwardFast

-------------------- DynamicNetwork instance --------------------

instance FromDynamicLayer Gelu where
  fromDynamicLayer inp _ _ = SpecNetLayer $ SpecGelu (tripleFromSomeShape inp)

instance ToDynamicLayer SpecGelu where
  toDynamicLayer _ _ (SpecGelu (rows, cols, depth)) =
     reifyNat rows $ \(_ :: (KnownNat rows) => Proxy rows) ->
     reifyNat cols $ \(_ :: (KnownNat cols) => Proxy cols) ->
     reifyNat depth $ \(_ :: (KnownNat depth) => Proxy depth) ->
     case (rows, cols, depth) of
         (_, 1, 1)    -> return $ SpecLayer Gelu (sing :: Sing ('D1 rows)) (sing :: Sing ('D1 rows))
         (_, _, 1) -> return $ SpecLayer Gelu (sing :: Sing ('D2 rows cols)) (sing :: Sing ('D2 rows cols))
         _    -> case (unsafeCoerce (Dict :: Dict()) :: Dict (KnownNat (rows GHC.TypeLits.* depth))) of
           Dict -> return $ SpecLayer Gelu (sing :: Sing ('D3 rows cols depth)) (sing :: Sing ('D3 rows cols depth))

-- | Create a specification for a elu layer.
specGelu1D :: Integer -> SpecNet
specGelu1D i = specGelu3D (i, 1, 1)

-- | Create a specification for a elu layer.
specGelu2D :: (Integer, Integer) -> SpecNet
specGelu2D (i, j) = specGelu3D (i, j, 1)

-- | Create a specification for a elu layer.
specGelu3D :: (Integer, Integer, Integer) -> SpecNet
specGelu3D = SpecNetLayer . SpecGelu

-- | Add a Gelu layer to your build.
gelu :: BuildM ()
gelu = buildGetLastLayerOut >>= buildAddSpec . SpecNetLayer . SpecGelu

-------------------- GNum instances --------------------

instance GNum Gelu where
  _ |* Gelu = Gelu
  _ |+ Gelu = Gelu

max_stars_repo_name: schnecki/grenade

max_issues_repo_name: schnecki/grenade

max_forks_repo_name: schnecki/grenade


text:
{-# LANGUAGE QuasiQuotes #-}
module Myelin.PyNN.SpiNNakerSpec where

import Control.Lens
import Control.Monad.State.Lazy
import Control.Monad.Trans.Except
import Data.Aeson
import Data.ByteString.Lazy.Char8
import Data.Either
import qualified Data.Map.Strict as Map
import Data.String.Interpolate
import Numeric.LinearAlgebra
import Text.Regex as Regex

import Myelin.Model
import Myelin.Neuron
import Myelin.PyNN.PyNN
import Myelin.SNN

import Test.Hspec

main :: IO ()
main = hspec spec

eval :: PyNNState a -> Either String a
eval s = evalState (runExceptT s) emptyPyNNModel

exec :: PyNNState a -> PyNNModel
exec s = execState (runExceptT s) emptyPyNNModel

spec :: Spec
spec = do
  describe "PyNN backend" $ do
    it "can translate an entire SNN model to a SpiNNaker script" $ do
      let input = Population 2 if_cond_exp "p0" 0
      let hidden = Population 4 if_cond_exp "p1" 1
      let output = Population 3 if_cond_exp "p2" 2
      let dictWithType = unpack $ encode if_cond_exp
      let dict = Regex.subRegex typeRegex dictWithType ""
      let effect1 = Static Excitatory (AllToAll (BiasGenerator (Constant 0)) (WeightGenerator (Constant 1)))
      let effect2 = Static Excitatory (AllToAll (Biases [0.0, 1.1, 2.2]) (WeightGenerator (GaussianRandom 2 1)))
      let edges = [ DenseProjection effect1 input hidden, DenseProjection effect2 hidden output ]
      let network = Network 0 [input] [hidden] edges [output]
      let task = Task SpiNNaker network 50
      let preample = PyNNPreample "# some config"
      let code = [i|import numpy as np
import volrpynn.spiNNaker as v
import pyNN.spiNNaker as pynn

# some config

p0 = pynn.Population(2, pynn.IF_cond_exp(**#{dict}))
p1 = pynn.Population(4, pynn.IF_cond_exp(**#{dict}))
p2 = pynn.Population(3, pynn.IF_cond_exp(**#{dict}))
layer0 = v.Dense(p0, p1, weights=1.0, biases=0.0)
layer1 = v.Dense(p1, p2, weights=np.random.normal(2.0, 1.0, (4, 3)), biases=np.array([0.0,1.1,2.2]))
l_decode = v.Decode(p2)
model = v.Model(layer0, layer1, l_decode)

optimiser = v.GradientDescentOptimiser(0.1, simulation_time=50.0)
if __name__ == "__main__":
    v.Main(model).train(optimiser)
|]
      translate task preample `shouldBe` Right code

max_stars_repo_name: volr/myelin

max_issues_repo_name: volr/myelin

max_forks_repo_name: volr/myelin


text:
{-# LANGUAGE ForeignFunctionInterface #-}
module Grenade.Layers.Internal.Pad (
    pad
  , crop
  ) where

import qualified Data.Vector.Storable        as U (unsafeFromForeignPtr0,
                                                   unsafeToForeignPtr0)

import           Foreign                     (mallocForeignPtrArray, withForeignPtr)
import           Foreign.Ptr                 (Ptr)
import           Numeric.LinearAlgebra       (Matrix, flatten)
import qualified Numeric.LinearAlgebra.Devel as U
import           System.IO.Unsafe            (unsafePerformIO)

import           Grenade.Types

pad :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix RealNum -> Matrix RealNum
pad channels padLeft padTop padRight padBottom rows cols rows' cols' m
 = let outMatSize      = rows' * cols' * channels
       vec             = flatten m
   in unsafePerformIO $ do
     outPtr        <- mallocForeignPtrArray outMatSize
     let (inPtr, _) = U.unsafeToForeignPtr0 vec

     withForeignPtr inPtr $ \inPtr' ->
       withForeignPtr outPtr $ \outPtr' ->
         pad_cpu inPtr' channels rows cols padLeft padTop padRight padBottom outPtr'

     let matVec = U.unsafeFromForeignPtr0 outPtr outMatSize
     return (U.matrixFromVector U.RowMajor (rows' * channels) cols' matVec)
{-# INLINE pad #-}

foreign import ccall unsafe
    pad_cpu
      :: Ptr RealNum -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr RealNum -> IO ()

crop :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix RealNum -> Matrix RealNum
crop channels padLeft padTop padRight padBottom rows cols _ _ m
 = let outMatSize      = rows * cols * channels
       vec             = flatten m
   in unsafePerformIO $ do
     outPtr        <- mallocForeignPtrArray outMatSize
     let (inPtr, _) = U.unsafeToForeignPtr0 vec

     withForeignPtr inPtr $ \inPtr' ->
       withForeignPtr outPtr $ \outPtr' ->
         crop_cpu inPtr' channels rows cols padLeft padTop padRight padBottom outPtr'

     let matVec = U.unsafeFromForeignPtr0 outPtr outMatSize
     return (U.matrixFromVector U.RowMajor (rows * channels) cols matVec)

foreign import ccall unsafe
    crop_cpu
      :: Ptr RealNum -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr RealNum -> IO ()

max_issues_repo_name: th-char/grenade

max_forks_repo_name: th-char/grenade