diff --git a/.envrc b/.envrc deleted file mode 100644 index 1d953f4..0000000 --- a/.envrc +++ /dev/null @@ -1 +0,0 @@ -use nix diff --git a/.gitignore b/.gitignore deleted file mode 100644 index b23893f..0000000 --- a/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -/result -elm-stuff -index.html diff --git a/Makefile b/Makefile deleted file mode 100644 index ff5b374..0000000 --- a/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -nix/elm-srcs.nix: playground/elm.json - cd playground && elm2nix convert > ../$@ - -nix/registry.dat: playground/elm.json - cd playground && elm2nix snapshot - mv playground/registry.dat $@ diff --git a/default.nix b/default.nix deleted file mode 100644 index 275ac7d..0000000 --- a/default.nix +++ /dev/null @@ -1,29 +0,0 @@ -{ ... }: -let - sources = import ./nix/sources.nix; - pkgs = import sources.nixpkgs { }; - gitignore = import sources.gitignore { }; -in rec { - datalog = pkgs.stdenv.mkDerivation { - name = "datalog"; - src = gitignore.gitignoreSource ./.; - - buildInputs = [ pkgs.elmPackages.elm pkgs.elmPackages.elm-test ]; - buildPhase = pkgs.elmPackages.fetchElmDeps { - elmPackages = import ./nix/elm-srcs.nix; - elmVersion = "0.19.1"; - registryDat = ./nix/registry.dat; - }; - - doCheck = true; - checkPhase = '' - elm-test - ''; - - installPhase = '' - mkdir -p $out/share/datalog - cd playground - elm make --optimize --output $out/share/datalog/index.html src/Main.elm - ''; - }; -} diff --git a/elm.json b/elm.json deleted file mode 100644 index 9bd4206..0000000 --- a/elm.json +++ /dev/null @@ -1,33 +0,0 @@ -{ - "type": "application", - "source-directories": [ - "src" - ], - "elm-version": "0.19.1", - "dependencies": { - "direct": { - "elm/browser": "1.0.2", - "elm/core": "1.0.5", - "elm/html": "1.0.0", - "elm/parser": "1.1.0", - "elm-community/graph": "6.0.0", - "rtfeldman/elm-sorter-experiment": "2.1.1" - }, - "indirect": { - "avh4/elm-fifo": "1.0.4", - "elm/json": "1.1.3", - "elm/time": "1.0.0", - "elm/url": "1.0.0", - "elm/virtual-dom": "1.0.2", - "elm-community/intdict": "3.0.0" - } - }, - "test-dependencies": { - "direct": { - "elm-explorations/test": "1.2.2" - }, - "indirect": { - "elm/random": "1.0.0" - } - } -} diff --git a/nix/elm-srcs.nix b/nix/elm-srcs.nix deleted file mode 100644 index 5c41e9c..0000000 --- a/nix/elm-srcs.nix +++ /dev/null @@ -1,82 +0,0 @@ -{ - - "rtfeldman/elm-sorter-experiment" = { - sha256 = "1vvvsg2axss25f7ilwk2pyhznv026bq3kj2fr8h2107g1lbgyabq"; - version = "2.1.1"; - }; - - "elm/html" = { - sha256 = "1n3gpzmpqqdsldys4ipgyl1zacn0kbpc3g4v3hdpiyfjlgh8bf3k"; - version = "1.0.0"; - }; - - "elm/parser" = { - sha256 = "0a3cxrvbm7mwg9ykynhp7vjid58zsw03r63qxipxp3z09qks7512"; - version = "1.1.0"; - }; - - "elm/browser" = { - sha256 = "0nagb9ajacxbbg985r4k9h0jadqpp0gp84nm94kcgbr5sf8i9x13"; - version = "1.0.2"; - }; - - "rtfeldman/elm-css" = { - sha256 = "0nxiyxyw3kw55whkpwhrcgc0dr6a8zlm2nqvsaqdw6mzkykg0ba6"; - version = "16.1.0"; - }; - - "elm/core" = { - sha256 = "19w0iisdd66ywjayyga4kv2p1v9rxzqjaxhckp8ni6n8i0fb2dvf"; - version = "1.0.5"; - }; - - "elm/url" = { - sha256 = "0av8x5syid40sgpl5vd7pry2rq0q4pga28b4yykn9gd9v12rs3l4"; - version = "1.0.0"; - }; - - "elm-community/graph" = { - sha256 = "1rwsq2126q0rb4vmy95ajxfm3m063d6lw0p90d510nzcrbm9bxbc"; - version = "6.0.0"; - }; - - "elm/json" = { - sha256 = "0kjwrz195z84kwywaxhhlnpl3p251qlbm5iz6byd6jky2crmyqyh"; - version = "1.1.3"; - }; - - "avh4/elm-fifo" = { - sha256 = "1ka0iz2psr75h4qz7hh5z1prclah1nais9aaycaxapfd7inqmrrc"; - version = "1.0.4"; - }; - - "rtfeldman/elm-hex" = { - sha256 = "1y0aa16asvwdqmgbskh5iba6psp43lkcjjw9mgzj3gsrg33lp00d"; - version = "1.0.0"; - }; - - "elm-community/intdict" = { - sha256 = "09i1fk63gp6sr6kc6ccs8g0kxvqhw5czghi9cl8flizanrgcmva1"; - version = "3.0.0"; - }; - - "elm/time" = { - sha256 = "0vch7i86vn0x8b850w1p69vplll1bnbkp8s383z7pinyg94cm2z1"; - version = "1.0.0"; - }; - - "elm/virtual-dom" = { - sha256 = "0q1v5gi4g336bzz1lgwpn5b1639lrn63d8y6k6pimcyismp2i1yg"; - version = "1.0.2"; - }; - - "elm-explorations/test" = { - sha256 = "1fsd7bajm7qa93r5pn3mdafqh3blpzya601jbs9l238p0hmvh576"; - version = "1.2.2"; - }; - - "elm/random" = { - sha256 = "138n2455wdjwa657w6sjq18wx2r0k60ibpc4frhbqr50sncxrfdl"; - version = "1.0.0"; - }; -} diff --git a/nix/registry.dat b/nix/registry.dat deleted file mode 100644 index 819aeb2..0000000 Binary files a/nix/registry.dat and /dev/null differ diff --git a/nix/sources.json b/nix/sources.json deleted file mode 100644 index 92b5a51..0000000 --- a/nix/sources.json +++ /dev/null @@ -1,38 +0,0 @@ -{ - "gitignore": { - "branch": "master", - "description": "Nix function for filtering local git sources", - "homepage": "", - "owner": "hercules-ci", - "repo": "gitignore", - "rev": "c4662e662462e7bf3c2a968483478a665d00e717", - "sha256": "1npnx0h6bd0d7ql93ka7azhj40zgjp815fw2r6smg8ch9p7mzdlx", - "type": "tarball", - "url": "https://github.com/hercules-ci/gitignore/archive/c4662e662462e7bf3c2a968483478a665d00e717.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, - "niv": { - "branch": "master", - "description": "Easy dependency management for Nix projects", - "homepage": "https://github.com/nmattia/niv", - "owner": "nmattia", - "repo": "niv", - "rev": "62fcf7d0859628f1834d84a7a0706ace0223c27e", - "sha256": "06ghvcsarvi32awxvgdxivaji8fsdhv46p49as8xx8whwia9d3rh", - "type": "tarball", - "url": "https://github.com/nmattia/niv/archive/62fcf7d0859628f1834d84a7a0706ace0223c27e.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, - "nixpkgs": { - "branch": "release-20.03", - "description": "Nix Packages collection", - "homepage": null, - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "929768261a3ede470eafb58d5b819e1a848aa8bf", - "sha256": "0zi54vbfi6i6i5hdd4v0l144y1c8rg6hq6818jjbbcnm182ygyfa", - "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/929768261a3ede470eafb58d5b819e1a848aa8bf.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - } -} diff --git a/nix/sources.nix b/nix/sources.nix deleted file mode 100644 index 1938409..0000000 --- a/nix/sources.nix +++ /dev/null @@ -1,174 +0,0 @@ -# This file has been generated by Niv. - -let - - # - # The fetchers. fetch_ fetches specs of type . - # - - fetch_file = pkgs: name: spec: - let - name' = sanitizeName name + "-src"; - in - if spec.builtin or true then - builtins_fetchurl { inherit (spec) url sha256; name = name'; } - else - pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; - - fetch_tarball = pkgs: name: spec: - let - name' = sanitizeName name + "-src"; - in - if spec.builtin or true then - builtins_fetchTarball { name = name'; inherit (spec) url sha256; } - else - pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; - - fetch_git = name: spec: - let - ref = - if spec ? ref then spec.ref else - if spec ? branch then "refs/heads/${spec.branch}" else - if spec ? tag then "refs/tags/${spec.tag}" else - abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; - in - builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; - - fetch_local = spec: spec.path; - - fetch_builtin-tarball = name: throw - ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. - $ niv modify ${name} -a type=tarball -a builtin=true''; - - fetch_builtin-url = name: throw - ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. - $ niv modify ${name} -a type=file -a builtin=true''; - - # - # Various helpers - # - - # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 - sanitizeName = name: - ( - concatMapStrings (s: if builtins.isList s then "-" else s) - ( - builtins.split "[^[:alnum:]+._?=-]+" - ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) - ) - ); - - # The set of packages used when specs are fetched using non-builtins. - mkPkgs = sources: system: - let - sourcesNixpkgs = - import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; - hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; - hasThisAsNixpkgsPath = == ./.; - in - if builtins.hasAttr "nixpkgs" sources - then sourcesNixpkgs - else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then - import {} - else - abort - '' - Please specify either (through -I or NIX_PATH=nixpkgs=...) or - add a package called "nixpkgs" to your sources.json. - ''; - - # The actual fetching function. - fetch = pkgs: name: spec: - - if ! builtins.hasAttr "type" spec then - abort "ERROR: niv spec ${name} does not have a 'type' attribute" - else if spec.type == "file" then fetch_file pkgs name spec - else if spec.type == "tarball" then fetch_tarball pkgs name spec - else if spec.type == "git" then fetch_git name spec - else if spec.type == "local" then fetch_local spec - else if spec.type == "builtin-tarball" then fetch_builtin-tarball name - else if spec.type == "builtin-url" then fetch_builtin-url name - else - abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; - - # If the environment variable NIV_OVERRIDE_${name} is set, then use - # the path directly as opposed to the fetched source. - replace = name: drv: - let - saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; - ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; - in - if ersatz == "" then drv else - # this turns the string into an actual Nix path (for both absolute and - # relative paths) - if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; - - # Ports of functions for older nix versions - - # a Nix version of mapAttrs if the built-in doesn't exist - mapAttrs = builtins.mapAttrs or ( - f: set: with builtins; - listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) - ); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 - range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 - stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 - stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); - concatMapStrings = f: list: concatStrings (map f list); - concatStrings = builtins.concatStringsSep ""; - - # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 - optionalAttrs = cond: as: if cond then as else {}; - - # fetchTarball version that is compatible between all the versions of Nix - builtins_fetchTarball = { url, name ? null, sha256 }@attrs: - let - inherit (builtins) lessThan nixVersion fetchTarball; - in - if lessThan nixVersion "1.12" then - fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchTarball attrs; - - # fetchurl version that is compatible between all the versions of Nix - builtins_fetchurl = { url, name ? null, sha256 }@attrs: - let - inherit (builtins) lessThan nixVersion fetchurl; - in - if lessThan nixVersion "1.12" then - fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchurl attrs; - - # Create the final "sources" from the config - mkSources = config: - mapAttrs ( - name: spec: - if builtins.hasAttr "outPath" spec - then abort - "The values in sources.json should not have an 'outPath' attribute" - else - spec // { outPath = replace name (fetch config.pkgs name spec); } - ) config.sources; - - # The "config" used by the fetchers - mkConfig = - { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null - , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) - , system ? builtins.currentSystem - , pkgs ? mkPkgs sources system - }: rec { - # The sources, i.e. the attribute set of spec name to spec - inherit sources; - - # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers - inherit pkgs; - }; - -in -mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/playground/elm.json b/playground/elm.json deleted file mode 100644 index 6580b5b..0000000 --- a/playground/elm.json +++ /dev/null @@ -1,36 +0,0 @@ -{ - "type": "application", - "source-directories": [ - "src", - "../src" - ], - "elm-version": "0.19.1", - "dependencies": { - "direct": { - "elm/browser": "1.0.2", - "elm/core": "1.0.5", - "elm/html": "1.0.0", - "elm/parser": "1.1.0", - "elm/url": "1.0.0", - "elm-community/graph": "6.0.0", - "rtfeldman/elm-css": "16.1.0", - "rtfeldman/elm-sorter-experiment": "2.1.1" - }, - "indirect": { - "avh4/elm-fifo": "1.0.4", - "elm/json": "1.1.3", - "elm/time": "1.0.0", - "elm/virtual-dom": "1.0.2", - "elm-community/intdict": "3.0.0", - "rtfeldman/elm-hex": "1.0.0" - } - }, - "test-dependencies": { - "direct": { - "elm-explorations/test": "1.2.2" - }, - "indirect": { - "elm/random": "1.0.0" - } - } -} diff --git a/playground/src/Main.elm b/playground/src/Main.elm deleted file mode 100644 index 43cf266..0000000 --- a/playground/src/Main.elm +++ /dev/null @@ -1,253 +0,0 @@ -module Main exposing (..) - -import Browser -import Browser.Navigation as Navigation exposing (Key) -import Css -import Css.Global -import Datalog -import Datalog.Atom as Atom -import Datalog.Parser -import Dict -import Html.Styled as Html exposing (Html) -import Html.Styled.Attributes as Attributes exposing (css) -import Html.Styled.Events as Events -import Url exposing (Url) -import Url.Builder -import Url.Parser -import Url.Parser.Query - - -type Evaluation - = Blank - | Error (List String) - | Unsolved Datalog.Program - | Solved Datalog.Database - - -type alias Model = - { source : String - , evaluation : Evaluation - , autoSolve : Bool - - -- routing stuff - , key : Key - , originalPath : List String - } - - -type Msg - = NewSource String - | SetAutoSolve Bool - | Solve - | Save - | OnUrlChange Url - | OnUrlRequest Browser.UrlRequest - - -init : () -> Url -> Key -> ( Model, Cmd Msg ) -init _ url key = - let - initialSource = - sourceFromUrl url - in - ( { source = initialSource - , evaluation = - case Datalog.Parser.parse initialSource of - Ok program -> - Solved (Datalog.solve program) - - Err errs -> - Error errs - , autoSolve = True - , key = key - , originalPath = - url.path - |> String.split "/" - |> List.filter ((/=) "") - } - , Cmd.none - ) - - -sourceFromUrl : Url -> String -sourceFromUrl url = - -- https://github.com/elm/url/issues/17 - { url | path = "" } - |> Url.Parser.parse (Url.Parser.query (Url.Parser.Query.string "program")) - |> Maybe.andThen identity - |> Maybe.withDefault "" - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case msg of - NewSource source -> - ( { model - | source = source - , evaluation = - case Datalog.Parser.parse source of - Err problems -> - Error problems - - Ok program -> - if model.autoSolve then - Solved (Datalog.solve program) - - else - Unsolved program - } - , Cmd.none - ) - - Save -> - ( model - , Navigation.pushUrl model.key - (Url.Builder.absolute - model.originalPath - [ Url.Builder.string "program" model.source ] - ) - ) - - SetAutoSolve True -> - ( { model - | autoSolve = True - , evaluation = - case model.evaluation of - Unsolved program -> - Solved (Datalog.solve program) - - _ -> - model.evaluation - } - , Cmd.none - ) - - SetAutoSolve False -> - ( { model | autoSolve = False }, Cmd.none ) - - Solve -> - ( { model - | evaluation = - case model.evaluation of - Unsolved program -> - Solved (Datalog.solve program) - - _ -> - model.evaluation - } - , Cmd.none - ) - - OnUrlChange url -> - update - (NewSource (sourceFromUrl url)) - { model - | originalPath = - url.path - |> String.split "/" - |> List.filter ((/=) "") - } - - OnUrlRequest (Browser.External url) -> - ( model, Navigation.load url ) - - OnUrlRequest (Browser.Internal _) -> - ( { model | source = "I got an internal URL request but I'm not set up to handle those." }, Cmd.none ) - - -view : Model -> Browser.Document Msg -view model = - { title = "Datalog Time!" - , body = - [ Css.Global.global [ Css.Global.html [ Css.backgroundColor (Css.hex "B0E0E6") ] ] - |> Html.toUnstyled - , Html.main_ - [ css - [ Css.maxWidth (Css.px 800) - , Css.minHeight (Css.vh 100) - , Css.margin2 Css.zero Css.auto - , Css.padding (Css.px 20) - , Css.boxSizing Css.borderBox - , Css.boxShadow5 Css.zero Css.zero (Css.px 10) (Css.px 1) (Css.rgba 0 0 0 0.25) - , Css.fontFamily Css.sansSerif - , Css.backgroundColor (Css.hex "FFF") - ] - ] - [ Html.h1 [] - [ Html.text "Datalog Time! (" - , Html.a [ Attributes.href "https://git.bytes.zone/brian/bad-datalog" ] [ Html.text "source" ] - , Html.text ")" - ] - , Html.label [] - [ Html.input - [ Attributes.type_ "checkbox" - , Attributes.checked model.autoSolve - , Events.onCheck SetAutoSolve - ] - [] - , Html.text "automatically solve" - ] - , Html.button - [ Events.onClick Save ] - [ Html.text "Save" ] - , Html.textarea - [ Events.onInput NewSource - , Attributes.value model.source - , css - [ Css.width (Css.pct 100) - , Css.height (Css.px 300) - , Css.padding (Css.px 20) - , Css.boxSizing Css.borderBox - , Css.border3 (Css.px 1) Css.solid (Css.hex "AAA") - , Css.borderRadius (Css.px 10) - , Css.fontFamily Css.monospace - ] - ] - [] - , case model.evaluation of - Blank -> - Html.p [] [ Html.text "Enter a program above!" ] - - Error errors -> - Html.ul [] - (List.map - (\err -> Html.li [] [ Html.pre [] [ Html.text err ] ]) - errors - ) - - Unsolved program -> - Html.p [] - [ Html.text "Sweet, it parses! Now " - , Html.button [ Events.onClick Solve ] [ Html.text "solve" ] - , Html.text " this bad boy!" - ] - - Solved database -> - Html.dl [] - (Dict.foldr - (\( name, _ ) ( first, rest ) soFar -> - Html.dt [] [ Html.pre [] [ Html.text name ] ] - :: List.map - (\atom -> Html.dd [] [ Html.pre [] [ Html.text (Atom.toString atom) ] ]) - (first :: rest) - ++ soFar - ) - [] - database - ) - ] - |> Html.toUnstyled - ] - } - - -main : Program () Model Msg -main = - Browser.application - { init = init - , update = update - , view = view - , onUrlChange = OnUrlChange - , onUrlRequest = OnUrlRequest - , subscriptions = \_ -> Sub.none - } diff --git a/shell.nix b/shell.nix deleted file mode 100644 index fa8d245..0000000 --- a/shell.nix +++ /dev/null @@ -1,23 +0,0 @@ -{ ... }: -let - sources = import ./nix/sources.nix; - - nixpkgs = import sources.nixpkgs { }; - - niv = import sources.niv { }; -in with nixpkgs; -stdenv.mkDerivation { - name = "bad-datalog"; - buildInputs = [ - niv.niv - git - gnumake - - # elm - elmPackages.elm - elmPackages.elm-format - elmPackages.elm-test - elmPackages.elm-live - elm2nix - ]; -} diff --git a/solving-by-hand.md b/solving-by-hand.md deleted file mode 100644 index 544d441..0000000 --- a/solving-by-hand.md +++ /dev/null @@ -1,98 +0,0 @@ -Say I had the following program computing which parts of a graph were reachable from `a`: - -``` -link(a, b) -link(b, c) - -reachable(From, To) :- link(From, To) -reachable(From, To) :- link(From, Middle), reachable(Middle, To) - -query(To) :- reachable(a, To) -``` - -How would I solve this? - -I guess I'd look at the rules as a first pass. Anything that doesn't have a body I'd just hold on to. - -Then I guess I'd look at the first definition of `reachable`... - -``` -reachable(From, To) :- link(From, Middle) -``` - -I'd see what `link` rules I had. All of these will unify, so I guess I'd have a bunch of substitutions that looked like this: - -``` -From: a, To: b -From: b, To: c -``` - -I'd apply my substitutions to `reachable` to get two more rules: - -``` -reachable(a, b) -reachable(b, c) -``` - -My old implementation just kind of hangs onto those things until the next iteration. I'm not sure why they can't enter the IDB immediately. - ---- - -Moving on to the second definition of `reachable`: - -``` -reachable(From, To) :- link(From, Middle), reachable(Middle, To) -``` - -First I'm looking at `link` again. I already found that this gives me the following substitutions: - -``` -From: a, Middle: b -From: b, Middle: c -``` - -Now for the recursive call to `reachable`. Since I already have substitutions, I can make the following partial replacements for the atom: - -``` -reachable(b, To) -reachable(c, To) -``` - -Now for each of those, I'll try to unify with all the facts I know about `reachable`. To start with, I don't know anything so this unification fails (which is not the implementation I may have arrived at by default, so I'm glad I'm thinking this through.) - -Assuming the opposite (e.g. because I'm in the next iteration or whatever) I can unify with each fact. For the first partial derivation above, that looks like: - -``` -reachable(b, To) + reachable(a, b) -> doesn't unify -reachable(b, To) + reachable(b, c) -> From: a, Middle: b, To: c -``` - -For the other, it looks like: - -``` -reachable(c, To) + reachable(a, b) -> doesn't unify -reachable(c, To) + reachable(b, c) -> doesn't unify -``` - -So I get one sucessful unification. That's all the rules here, so I can do substitution on the head to get: - -``` -reachable(a, c) -``` - ---- - -Now on to `query`... - -``` -query(To) :- reachable(a, To) -``` - -Assuming that I have all the previously-derived facts, I've just got to look up substituions for `reachable` and then apply them to `query`. So I get: - -``` -query(b) -query(c) -``` - -Which is exactly what I want! diff --git a/src/Datalog.elm b/src/Datalog.elm deleted file mode 100644 index 78b31d2..0000000 --- a/src/Datalog.elm +++ /dev/null @@ -1,249 +0,0 @@ -module Datalog exposing (Database, Problem(..), Program, program, solve) - -import Datalog.Atom as Atom exposing (Atom, Substitutions) -import Datalog.Negatable as Negatable exposing (Direction(..), Negatable(..)) -import Datalog.Rule as Rule exposing (Rule) -import Datalog.Term as Term exposing (Term(..)) -import Dict exposing (Dict) -import Graph - - -type Program - = Program (List (List Rule)) - - -program : List Rule -> Result Problem Program -program rules = - Result.map Program (stratify rules) - - -type Problem - = CycleWithNegation - - - --- STRATIFICATION - - -stratify : List Rule -> Result Problem (List (List Rule)) -stratify rules = - -- some future version of this function may want to create the entire graph - -- in a single pass over the rules. That'd be fine, of course, and faster, - -- but potentially way harder to work with. Keep it simple for now! - let - namesToIds = - rules - |> List.concatMap - (\rule -> - Atom.key (Rule.head rule) - :: List.map - (\atom -> Atom.key (Negatable.value atom)) - (Rule.body rule) - ) - |> List.foldl - (\key soFar -> - Dict.update key - (\value -> - case value of - Just id -> - Just id - - Nothing -> - Just (Dict.size soFar) - ) - soFar - ) - Dict.empty - - nodes = - Dict.foldl - (\key id soFar -> - Graph.Node id key :: soFar - ) - [] - namesToIds - - edges = - rules - |> List.concatMap - (\rule -> - let - headId = - namesToIds - |> Dict.get (Atom.key (Rule.head rule)) - |> Maybe.withDefault -1 - in - List.map - (\(Negatable direction bodyAtom) -> - Graph.Edge - (namesToIds - |> Dict.get (Atom.key bodyAtom) - |> Maybe.withDefault -1 - ) - headId - direction - ) - (Rule.body rule) - ) - - precedenceGraph = - Graph.fromNodesAndEdges nodes edges - - rulesByName = - List.foldr - (\rule soFar -> - Dict.update (Atom.key (Rule.head rule)) - (\maybeRules -> - case maybeRules of - Nothing -> - Just [ rule ] - - Just already -> - Just (rule :: already) - ) - soFar - ) - Dict.empty - rules - - scc = - Graph.stronglyConnectedComponents precedenceGraph - |> Result.mapError (List.map Graph.edges) - in - case Graph.stronglyConnectedComponents precedenceGraph of - -- pretty unlikely, but ok fine we'll handle it - Ok acyclic -> - Ok [ rules ] - - Err condensation -> - if List.any (Graph.edges >> List.map .label >> List.member Negative) condensation then - Err CycleWithNegation - - else - condensation - |> List.concatMap - (Graph.nodes - >> List.filterMap (\{ label } -> Dict.get label rulesByName |> Maybe.map (Tuple.pair label)) - >> Dict.fromList - >> Dict.values - ) - |> Ok - - - --- EVALUATION - - -{-| This is cheating a bit. A database is only ground atoms--that is, atoms -whose terms are all constants. --} -type alias Database = - Dict ( String, Int ) ( Atom, List Atom ) - - -insertAtom : Atom -> Database -> Database -insertAtom atom database = - Dict.update (Atom.key atom) - (\maybeExisting -> - case maybeExisting of - Just ( first, rest ) -> - if atom == first || List.member atom rest then - Just ( first, rest ) - - else - Just ( atom, first :: rest ) - - Nothing -> - Just ( atom, [] ) - ) - database - - -solve : Program -> Database -solve (Program rules) = - List.foldl solveHelp Dict.empty rules - - -solveHelp : List Rule -> Database -> Database -solveHelp rules database = - let - expanded = - List.foldl evaluateRule database rules - in - if expanded == database then - database - - else - solveHelp rules expanded - - -evaluateRule : Rule -> Database -> Database -evaluateRule rule database = - if Rule.isFact rule then - insertAtom (Rule.head rule) database - - else - Rule.body rule - |> List.foldl - (\bodyAtom substitutions -> - List.concatMap - (evaluateAtom database bodyAtom) - substitutions - ) - [ Atom.emptySubstitutions ] - |> List.foldl - (\substitution dbProgress -> - let - possiblyGround = - Atom.substitute (Rule.head rule) substitution - in - if Atom.isGround possiblyGround then - insertAtom possiblyGround dbProgress - - else - dbProgress - ) - database - - -evaluateAtom : Database -> Negatable Atom -> Substitutions -> List Substitutions -evaluateAtom database negatableAtom substitutions = - let - bound = - Negatable.map (\atom -> Atom.substitute atom substitutions) negatableAtom - in - case Dict.get (Atom.key (Negatable.value bound)) database of - Nothing -> - [] - - Just ( first, rest ) -> - evaluateAtomHelp bound substitutions (first :: rest) [] - - -evaluateAtomHelp : Negatable Atom -> Substitutions -> List Atom -> List Substitutions -> List Substitutions -evaluateAtomHelp bound substitutions facts soFar = - case facts of - [] -> - soFar - - fact :: rest -> - case Negatable.map (Atom.unify fact) bound of - Negatable Positive (Just outcome) -> - evaluateAtomHelp - bound - substitutions - rest - (Atom.mergeSubstitutions substitutions outcome :: soFar) - - Negatable Positive Nothing -> - evaluateAtomHelp bound substitutions rest soFar - - Negatable Negative (Just _) -> - [] - - Negatable Negative Nothing -> - evaluateAtomHelp - bound - substitutions - rest - (substitutions :: soFar) diff --git a/src/Datalog/Atom.elm b/src/Datalog/Atom.elm deleted file mode 100644 index 50b82eb..0000000 --- a/src/Datalog/Atom.elm +++ /dev/null @@ -1,143 +0,0 @@ -module Datalog.Atom exposing - ( Atom, atom, key, isGround, variables - , Substitutions, emptySubstitutions, unify, substitute, mergeSubstitutions - , toString - ) - -{-| - -@docs Atom, atom, key, isGround, variables - -@docs Substitutions, emptySubstitutions, unify, substitute, mergeSubstitutions - -@docs toString - --} - -import Datalog.Term as Term exposing (Term(..)) -import Sort.Dict as Dict exposing (Dict) - - -type Atom - = Atom String Int (List Term) - - -atom : String -> List Term -> Atom -atom name terms = - Atom name (List.length terms) terms - - -{-| TODO: this is useful but kind of internal. Should it move somewhere else, -or split into `name` and `size`? --} -key : Atom -> ( String, Int ) -key (Atom name arity _) = - ( name, arity ) - - -isGround : Atom -> Bool -isGround (Atom _ _ terms) = - not (List.isEmpty terms) && List.all Term.isGround terms - - -variables : Atom -> List Term.Variable -variables (Atom _ _ terms) = - List.filterMap - (\term -> - case term of - Term.Constant _ -> - Nothing - - Term.Variable var -> - Just var - ) - terms - - -type alias Substitutions = - Dict Term.Variable Term.Constant - - -emptySubstitutions : Substitutions -emptySubstitutions = - Dict.empty Term.variableSorter - - -unify : Atom -> Atom -> Maybe Substitutions -unify (Atom aName aArity aTerms) (Atom bName bArity bTerms) = - if aName == bName && aArity == bArity then - unifyHelp (List.map2 Tuple.pair aTerms bTerms) emptySubstitutions - - else - Nothing - - -unifyHelp : List ( Term, Term ) -> Substitutions -> Maybe Substitutions -unifyHelp termPairs substitutions = - let - variableToConstant : Term.Variable -> Term.Constant -> List ( Term, Term ) -> Maybe Substitutions - variableToConstant var constant rest = - if Term.isAnonymous var then - unifyHelp rest substitutions - - else - case Dict.get var substitutions of - Nothing -> - unifyHelp rest (Dict.insert var constant substitutions) - - Just alreadyBound -> - if alreadyBound == constant then - unifyHelp rest substitutions - - else - Nothing - in - case termPairs of - [] -> - Just substitutions - - ( Constant a, Constant b ) :: rest -> - if a == b then - unifyHelp rest substitutions - - else - Nothing - - ( Variable _, Variable _ ) :: rest -> - unifyHelp rest substitutions - - ( Variable var, Constant constant ) :: rest -> - variableToConstant var constant rest - - ( Constant constant, Variable var ) :: rest -> - variableToConstant var constant rest - - -substitute : Atom -> Substitutions -> Atom -substitute (Atom name arity terms) substitutions = - terms - |> List.map - (\term -> - case term of - Constant _ -> - term - - Variable var -> - case Dict.get var substitutions of - Just boundTerm -> - Constant boundTerm - - Nothing -> - term - ) - |> Atom name arity - - -mergeSubstitutions : Substitutions -> Substitutions -> Substitutions -mergeSubstitutions a b = - Dict.insertAll a b - - -toString : Atom -> String -toString (Atom name _ terms) = - name ++ "(" ++ String.join ", " (List.map Term.toString terms) ++ ")" diff --git a/src/Datalog/Negatable.elm b/src/Datalog/Negatable.elm deleted file mode 100644 index f3ff2c0..0000000 --- a/src/Datalog/Negatable.elm +++ /dev/null @@ -1,40 +0,0 @@ -module Datalog.Negatable exposing - ( Negatable(..), Direction(..), positive, negative - , value, map - ) - -{-| - -@docs Negatable, Direction, positive, negative -@docs value, map - --} - - -type Negatable a - = Negatable Direction a - - -type Direction - = Positive - | Negative - - -positive : a -> Negatable a -positive = - Negatable Positive - - -negative : a -> Negatable a -negative = - Negatable Negative - - -value : Negatable a -> a -value (Negatable _ a) = - a - - -map : (a -> b) -> Negatable a -> Negatable b -map fn (Negatable direction_ a) = - Negatable direction_ (fn a) diff --git a/src/Datalog/Parser.elm b/src/Datalog/Parser.elm deleted file mode 100644 index 098b434..0000000 --- a/src/Datalog/Parser.elm +++ /dev/null @@ -1,381 +0,0 @@ -module Datalog.Parser exposing (parse) - -import Datalog exposing (Program, program) -import Datalog.Atom as Atom exposing (Atom) -import Datalog.Negatable as Negatable exposing (Negatable) -import Datalog.Rule as Rule exposing (Rule) -import Datalog.Term as Term exposing (Term) -import Dict -import Parser.Advanced as Parser exposing ((|.), (|=), Parser) -import Set - - -parse : String -> Result (List String) Datalog.Program -parse source = - source - |> Parser.run parser - |> Result.mapError (niceErrors source) - - -niceErrors : String -> List (Parser.DeadEnd Context Problem) -> List String -niceErrors source deadEnds = - deadEnds - |> List.foldr - (\deadEnd groups -> - Dict.update - ( deadEndSpan deadEnd, niceContextStack deadEnd.contextStack ) - (\maybeExisting -> - case maybeExisting of - Just ( first, rest ) -> - Just ( deadEnd, first.problem :: rest ) - - Nothing -> - Just ( deadEnd, [] ) - ) - groups - ) - Dict.empty - |> Dict.values - |> List.map (niceError source) - - -deadEndSpan : Parser.DeadEnd Context Problem -> ( ( Int, Int ), ( Int, Int ) ) -deadEndSpan deadEnd = - let - locations = - ( deadEnd.row, deadEnd.col ) - :: List.map (\{ row, col } -> ( row, col )) deadEnd.contextStack - in - Maybe.map2 Tuple.pair - (List.minimum locations) - (List.maximum locations) - |> Maybe.withDefault ( ( 0, 0 ), ( 0, 0 ) ) - - -niceContextStack : List { otherStuff | context : Context } -> String -niceContextStack = - List.foldr - (\before after -> - niceContext before.context - ++ (if after == "" then - after - - else - " inside " ++ after - ) - ) - "" - - -niceError : String -> ( Parser.DeadEnd Context Problem, List Problem ) -> String -niceError source ( deadEnd, moreProblems ) = - let - ( ( startRow, _ ), ( endRow, problemCol ) ) = - deadEndSpan deadEnd - - lines = - String.lines source - |> List.drop (startRow - 1) - |> List.take (endRow - startRow + 1) - |> String.join "\n" - - pointer = - List.concat - [ List.repeat (problemCol - 1) ' ' - , [ '^' ] - ] - |> String.fromList - - problems = - case deadEnd.problem :: moreProblems of - [] -> - "This shouldn't be possible, and indicates a bug. Ask for help!" - - [ only ] -> - "I was expecting " ++ niceProblem only - - many -> - many - |> List.map (\problem -> " - " ++ niceProblem problem) - |> String.join "\n" - |> (++) "I was expecting one of these things:\n\n" - in - "I ran into a problem while parsing " - ++ niceContextStack deadEnd.contextStack - ++ " at line " - ++ String.fromInt endRow - ++ ", column " - ++ String.fromInt problemCol - ++ ":\n\n" - ++ lines - ++ "\n" - ++ pointer - ++ "\n\n" - ++ problems - - -type Context - = Rule - | Atom (Maybe String) - - -niceContext : Context -> String -niceContext context = - case context of - Rule -> - "a rule" - - Atom Nothing -> - "an atom" - - Atom (Just name) -> - "an atom named " ++ name - - -type Problem - = ExpectingAtomName - | ExpectingStartOfTerms - | ExpectingEndOfTerms - | ExpectingComma - | ExpectingOpeningQuote - | ExpectingClosingQuote - | ExpectingNumber - | InvalidNumber - | ExpectingVariable - | ExpectingImplies - | ExpectingNewline - | ExpectingEnd - | ExpectingPeriod - | ExpectingUnderscore - | ExpectingNot - | ExpectingComment - | InvalidRule Rule.Problem - | InvalidProgram Datalog.Problem - - -niceProblem : Problem -> String -niceProblem problem = - case problem of - ExpectingAtomName -> - "an atom name" - - ExpectingStartOfTerms -> - "an opening parenthesis to start the list of terms in the atom" - - ExpectingEndOfTerms -> - "a closing parenthesis to end the list of terms in the atom" - - ExpectingComma -> - "a comma" - - ExpectingOpeningQuote -> - "a quote (`\"`) to start a constant term" - - ExpectingClosingQuote -> - "a closing quote (`\"`) to end this constant term" - - ExpectingNumber -> - "a number for an integer term" - - InvalidNumber -> - "an integer like 1234 (no floats, hex, octal, etc.)" - - ExpectingVariable -> - "a variable (a name starting with a letter and continuing on with alphanumeric characters)" - - ExpectingImplies -> - "a `:-` followed by a rule body" - - ExpectingNewline -> - "a newline" - - ExpectingEnd -> - "the end of the program" - - ExpectingPeriod -> - "a period to end a rule" - - ExpectingUnderscore -> - "an underscore for an anonymous variable" - - ExpectingNot -> - "a 'not' to negate an atom in the rule body" - - ExpectingComment -> - "a line comment starting with '--'" - - InvalidRule Rule.NotRangeRestricted -> - "a rule, which must use all the variables from the head in the body" - - InvalidRule Rule.UnnamedHeadVariable -> - "a rule, which may not use anonymous variables in the head" - - InvalidRule Rule.VariableAppearsNegatedButNotPositive -> - "a rule, which may not contain atoms that appear in a negated expression without appearing in a positive one" - - InvalidProgram Datalog.CycleWithNegation -> - -- TODO: wow, awkward way to phase this. Make it better! - "a program, which may not contain cycles including negation" - - -parser : Parser Context Problem Program -parser = - Parser.succeed identity - |. spacesOrComment - |= Parser.loop [] rules - |> Parser.andThen - (\parsedRules -> - case program parsedRules of - Ok program_ -> - Parser.succeed program_ - - Err problem -> - Parser.problem (InvalidProgram problem) - ) - - -rules : List Rule -> Parser Context Problem (Parser.Step (List Rule) (List Rule)) -rules soFar = - Parser.oneOf - [ Parser.succeed (\rule_ -> Parser.Loop (rule_ :: soFar)) - |= rule - |. spacesOrComment - , Parser.end ExpectingEnd - |> Parser.map (\() -> Parser.Done (List.reverse soFar)) - ] - - -rule : Parser Context Problem Rule -rule = - (Parser.succeed Rule.rule - |= atom - |= Parser.oneOf - [ Parser.succeed (::) - |. spacesOrComment - |. Parser.token (Parser.Token ":-" ExpectingImplies) - |. spacesOrComment - |= bodyAtom - |= Parser.loop [] ruleTail - , Parser.succeed [] - |. Parser.token (Parser.Token "." ExpectingPeriod) - ] - ) - |> Parser.andThen - (\ruleResult -> - case ruleResult of - Ok validRule -> - Parser.succeed validRule - - Err err -> - Parser.problem (InvalidRule err) - ) - |> Parser.inContext Rule - - -ruleTail : List (Negatable Atom) -> Parser Context Problem (Parser.Step (List (Negatable Atom)) (List (Negatable Atom))) -ruleTail soFar = - Parser.oneOf - [ Parser.succeed (\atom_ -> Parser.Loop (atom_ :: soFar)) - |. spacesOrComment - |. Parser.token (Parser.Token "," ExpectingComma) - |. spacesOrComment - |= bodyAtom - , Parser.map (\() -> Parser.Done (List.reverse soFar)) - (Parser.token (Parser.Token "." ExpectingPeriod)) - ] - - -bodyAtom : Parser Context Problem (Negatable Atom) -bodyAtom = - Parser.succeed (\negator atom_ -> negator atom_) - |= Parser.oneOf - [ Parser.succeed Negatable.negative - |. Parser.token (Parser.Token "not " ExpectingNot) - , Parser.succeed Negatable.positive - ] - |= atom - - -atom : Parser Context Problem Atom -atom = - let - atomName = - Parser.variable - { start = Char.isLower - , inner = Char.isAlphaNum - , reserved = Set.empty - , expecting = ExpectingAtomName - } - - atomTerms = - Parser.sequence - { start = Parser.Token "(" ExpectingStartOfTerms - , separator = Parser.Token "," ExpectingComma - , end = Parser.Token ")" ExpectingEndOfTerms - , spaces = spacesOrComment - , item = term - , trailing = Parser.Forbidden - } - in - Parser.inContext (Atom Nothing) atomName - |> Parser.andThen - (\name -> - Parser.inContext (Atom (Just name)) <| - Parser.succeed Atom.atom - |= Parser.succeed name - |. spacesOrComment - |= atomTerms - ) - - -term : Parser Context Problem Term -term = - Parser.oneOf [ variable, string, int, anonymous ] - - -string : Parser Context Problem Term -string = - Parser.succeed (Term.Constant << Term.String) - |. Parser.token (Parser.Token "\"" ExpectingOpeningQuote) - |= Parser.getChompedString (Parser.chompWhile (\c -> c /= '"')) - |. Parser.token (Parser.Token "\"" ExpectingClosingQuote) - - -int : Parser Context Problem Term -int = - Parser.int ExpectingNumber InvalidNumber - |> Parser.map (Term.Constant << Term.Int) - - -variable : Parser Context Problem Term -variable = - Parser.variable - { start = Char.isAlpha - , inner = Char.isAlphaNum - , reserved = Set.empty - , expecting = ExpectingVariable - } - |> Parser.map (Term.Variable << Term.Named) - - -anonymous : Parser Context Problem Term -anonymous = - Parser.succeed Term.anonymous - |. Parser.token (Parser.Token "_" ExpectingUnderscore) - - -spacesOrComment : Parser Context Problem () -spacesOrComment = - spaces - |. Parser.oneOf [ lineComment, Parser.succeed () ] - |. spaces - - -spaces : Parser Context Problem () -spaces = - Parser.chompWhile (\c -> c == ' ' || c == '\n') - - -lineComment : Parser Context Problem () -lineComment = - Parser.lineComment (Parser.Token "--" ExpectingComment) diff --git a/src/Datalog/Rule.elm b/src/Datalog/Rule.elm deleted file mode 100644 index 731b17a..0000000 --- a/src/Datalog/Rule.elm +++ /dev/null @@ -1,128 +0,0 @@ -module Datalog.Rule exposing (Problem(..), Rule, body, fact, head, isFact, rule, toString) - -import Datalog.Atom as Atom exposing (Atom) -import Datalog.Negatable as Negatable exposing (Direction(..), Negatable(..)) -import Datalog.Term as Term -import Sort.Set as Set - - -type Rule - = Rule Atom (List (Negatable Atom)) - - -type Problem - = NotRangeRestricted - | UnnamedHeadVariable - | VariableAppearsNegatedButNotPositive - - -rule : Atom -> List (Negatable Atom) -> Result Problem Rule -rule head_ body_ = - let - candidate = - Rule head_ body_ - in - if hasUnnamedHeadVariable candidate then - Err UnnamedHeadVariable - - else if not (isRangeRestricted candidate) then - Err NotRangeRestricted - - else if not (isNegationSafe candidate) then - Err VariableAppearsNegatedButNotPositive - - else - Ok candidate - - -fact : Atom -> Result Problem Rule -fact fact_ = - rule fact_ [] - - -isFact : Rule -> Bool -isFact (Rule head_ body_) = - Atom.isGround head_ && List.isEmpty body_ - - -hasUnnamedHeadVariable : Rule -> Bool -hasUnnamedHeadVariable (Rule head_ _) = - List.any Term.isAnonymous (Atom.variables head_) - - -{-| Do all the variables in the head occur in the body? --} -isRangeRestricted : Rule -> Bool -isRangeRestricted (Rule head_ body_) = - let - bodyVars = - List.concatMap (Negatable.value >> Atom.variables) body_ - in - List.all - (\headVar -> List.member headVar bodyVars) - (Atom.variables head_) - - -{-| Do all the variables in negated expressions also appear in positive -expressions? --} -isNegationSafe : Rule -> Bool -isNegationSafe (Rule _ body_) = - body_ - |> List.foldl - (\(Negatable direction atom) occurrences_ -> - List.foldl - (\variable occurrences -> - case direction of - Positive -> - { occurrences | positive = Set.insert variable occurrences.positive } - - Negative -> - { occurrences | negative = Set.insert variable occurrences.negative } - ) - occurrences_ - (Atom.variables atom) - ) - { positive = Set.empty Term.variableSorter - , negative = Set.empty Term.variableSorter - } - |> (\{ positive, negative } -> - negative - |> Set.dropIf (Set.memberOf positive) - |> Set.dropIf ((==) Term.Anonymous) - |> Set.isEmpty - ) - - -head : Rule -> Atom -head (Rule head_ _) = - head_ - - -body : Rule -> List (Negatable Atom) -body (Rule _ body_) = - body_ - - -toString : Rule -> String -toString (Rule head_ body_) = - case body_ of - [] -> - Atom.toString head_ ++ "." - - _ -> - Atom.toString head_ - ++ " :- " - ++ String.join ", " - (List.map - (\negatableAtom -> - case negatableAtom of - Negatable Positive atom -> - Atom.toString atom - - Negatable Negative atom -> - "not " ++ Atom.toString atom - ) - body_ - ) - ++ "." diff --git a/src/Datalog/Term.elm b/src/Datalog/Term.elm deleted file mode 100644 index 6b11c3e..0000000 --- a/src/Datalog/Term.elm +++ /dev/null @@ -1,83 +0,0 @@ -module Datalog.Term exposing (Constant(..), Term(..), Variable(..), anonymous, int, isAnonymous, isGround, string, toString, variable, variableSorter) - -import Sort exposing (Sorter) - - -type Term - = Constant Constant - | Variable Variable - - -type Constant - = String String - | Int Int - - -type Variable - = Named String - | Anonymous - - -variableSorter : Sorter Variable -variableSorter = - Sort.by - (\var -> - case var of - Named name -> - name - - Anonymous -> - "_" - ) - Sort.alphabetical - - -string : String -> Term -string = - Constant << String - - -int : Int -> Term -int = - Constant << Int - - -variable : String -> Term -variable = - Variable << Named - - -anonymous : Term -anonymous = - Variable Anonymous - - -isAnonymous : Variable -> Bool -isAnonymous var = - var == Anonymous - - -isGround : Term -> Bool -isGround term = - case term of - Constant _ -> - True - - Variable _ -> - False - - -toString : Term -> String -toString term = - case term of - Constant (String string_) -> - "\"" ++ string_ ++ "\"" - - Constant (Int int_) -> - String.fromInt int_ - - Variable (Named variable_) -> - variable_ - - Variable Anonymous -> - "_" diff --git a/tests/Datalog/AtomTests.elm b/tests/Datalog/AtomTests.elm deleted file mode 100644 index 52c4eac..0000000 --- a/tests/Datalog/AtomTests.elm +++ /dev/null @@ -1,219 +0,0 @@ -module Datalog.AtomTests exposing (..) - -import Datalog.Atom exposing (..) -import Datalog.Term as Term exposing (anonymous, int, string, variable) -import Expect -import Sort.Dict as Dict -import Test exposing (..) - - -isGroundTest : Test -isGroundTest = - describe "atom isGround" - [ test "if there are terms, the atom is ground" <| - \_ -> atom "x" [] |> isGround |> Expect.equal False - , test "if all terms are constant, the atom is ground" <| - \_ -> atom "x" [ string "a" ] |> isGround |> Expect.equal True - , test "if all terms are variable, the atom is not ground" <| - \_ -> atom "x" [ variable "X" ] |> isGround |> Expect.equal False - , test "with a mix of constant and variable terms, the atom is not ground" <| - \_ -> - atom "x" [ variable "X", string "a" ] - |> isGround - |> Expect.equal False - ] - - -variablesTest : Test -variablesTest = - describe "variables" - [ test "a variables shows up" <| - \_ -> - atom "x" [ variable "x" ] - |> variables - |> Expect.equal [ Term.Named "x" ] - , test "concrete terms does not show up" <| - \_ -> - atom "x" [ string "a", int 1 ] - |> variables - |> Expect.equal [] - ] - - -unifyTest : Test -unifyTest = - describe "unify" - [ test "atoms with different names do not unify" <| - \_ -> - unify (atom "a" []) (atom "b" []) - |> Expect.equal Nothing - , test "atoms with different arities do not unify" <| - \_ -> - unify - (atom "a" [ variable "A" ]) - (atom "a" [ variable "A", variable "B" ]) - |> Expect.equal Nothing - , test "conflicting constants do not unify" <| - \_ -> - unify - (atom "a" [ string "x" ]) - (atom "a" [ string "y" ]) - |> Expect.equal Nothing - , test "compatible constants unify" <| - \_ -> - unify - (atom "a" [ string "x" ]) - (atom "a" [ string "x" ]) - |> Expect.equal (Just emptySubstitutions) - , test "a unbound var/constant pair unifies" <| - \_ -> - unify - (atom "a" [ variable "X" ]) - (atom "a" [ string "a" ]) - |> Expect.equal (Just (singleton (Term.Named "X") (Term.String "a"))) - , test "a bound var/constant pair unifies if it does not conflict" <| - \_ -> - unify - (atom "a" [ variable "X", variable "X" ]) - (atom "a" [ string "a", string "a" ]) - |> Expect.equal (Just (singleton (Term.Named "X") (Term.String "a"))) - , test "a constant/bound var pair does not unify if it conflicts" <| - \_ -> - unify - (atom "a" [ variable "X", variable "X" ]) - (atom "a" [ string "a", string "b" ]) - |> Expect.equal Nothing - , test "a constant/unbound var pair unifies" <| - \_ -> - unify - (atom "a" [ string "a" ]) - (atom "a" [ variable "X" ]) - |> Expect.equal (Just (singleton (Term.Named "X") (Term.String "a"))) - , test "a constant/bound var pair unifies if it does not conflict" <| - \_ -> - unify - (atom "a" [ string "a", string "a" ]) - (atom "a" [ variable "X", variable "X" ]) - |> Expect.equal (Just (singleton (Term.Named "X") (Term.String "a"))) - , test "a bound var/constant pair does not unify if it conflicts" <| - \_ -> - unify - (atom "a" [ string "a", string "b" ]) - (atom "a" [ variable "X", variable "X" ]) - |> Expect.equal Nothing - , test "variables unify with each other but don't generate any bindings" <| - \_ -> - unify - (atom "a" [ variable "X" ]) - (atom "a" [ variable "Y" ]) - |> Expect.equal (Just emptySubstitutions) - , test "more than one variable can be bound in an atom" <| - \_ -> - unify - (atom "a" [ variable "X", variable "Y" ]) - (atom "a" [ string "a", string "b" ]) - |> Expect.equal - (Just - (Dict.fromList Term.variableSorter - [ ( Term.Named "X", Term.String "a" ) - , ( Term.Named "Y", Term.String "b" ) - ] - ) - ) - , test "multiple variables can cause conflicts which fail to unify" <| - \_ -> - unify - (atom "a" [ variable "X", variable "X" ]) - (atom "a" [ string "a", string "b" ]) - |> Expect.equal Nothing - , test "anonymous variables don't bind and cause conflicts" <| - \_ -> - unify - (atom "a" [ anonymous, anonymous ]) - (atom "a" [ string "a", string "b" ]) - |> Expect.equal (Just (Dict.empty Term.variableSorter)) - ] - - -substituteTest : Test -substituteTest = - describe "substitute" - [ test "an empty substitutions has no effect" <| - \_ -> - let - subject = - atom "a" [ variable "X" ] - in - substitute subject emptySubstitutions - |> Expect.equal subject - , test "an atom with no terms is unmodified" <| - \_ -> - let - subject = - atom "a" [] - in - substitute subject (singleton (Term.Named "X") (Term.String "a")) - |> Expect.equal subject - , test "a constant term is not replaed" <| - \_ -> - let - subject = - atom "a" [ string "a" ] - in - substitute subject (singleton (Term.Named "X") (Term.String "a")) - |> Expect.equal subject - , test "a variable term is replaced if there is a replacement" <| - \_ -> - substitute - (atom "a" [ variable "X" ]) - (singleton (Term.Named "X") (Term.String "a")) - |> Expect.equal (atom "a" [ string "a" ]) - , test "a variable term is not replace if there is no replacement" <| - \_ -> - let - subject = - atom "a" [ variable "X" ] - in - substitute subject (singleton (Term.Named "Y") (Term.String "a")) - |> Expect.equal subject - ] - - -mergeSubstitutionsTest : Test -mergeSubstitutionsTest = - describe "mergeSubstitutions" - [ test "keys in left should be preserved" <| - \_ -> - mergeSubstitutions - (singleton (Term.Named "X") (Term.String "a")) - emptySubstitutions - |> Dict.get (Term.Named "X") - |> Expect.equal (Just (Term.String "a")) - , test "keys in right should be preserved" <| - \_ -> - mergeSubstitutions - emptySubstitutions - (singleton (Term.Named "X") (Term.String "a")) - |> Dict.get (Term.Named "X") - |> Expect.equal (Just (Term.String "a")) - , test "keys in both should be preserved" <| - \_ -> - mergeSubstitutions - (singleton (Term.Named "X") (Term.String "a")) - (singleton (Term.Named "Y") (Term.String "b")) - |> Expect.all - [ Dict.get (Term.Named "X") >> Expect.equal (Just (Term.String "a")) - , Dict.get (Term.Named "Y") >> Expect.equal (Just (Term.String "b")) - ] - , test "keys in left take precedence" <| - \_ -> - mergeSubstitutions - (singleton (Term.Named "X") (Term.String "a")) - (singleton (Term.Named "X") (Term.String "b")) - |> Dict.get (Term.Named "X") - |> Expect.equal (Just (Term.String "a")) - ] - - -singleton = - Dict.singleton Term.variableSorter diff --git a/tests/Datalog/ParserTests.elm b/tests/Datalog/ParserTests.elm deleted file mode 100644 index a856f19..0000000 --- a/tests/Datalog/ParserTests.elm +++ /dev/null @@ -1,176 +0,0 @@ -module Datalog.ParserTests exposing (..) - -import Datalog exposing (Program, program) -import Datalog.Atom as Atom -import Datalog.Negatable exposing (negative, positive) -import Datalog.Parser exposing (..) -import Datalog.Rule as Rule exposing (Rule) -import Datalog.Term as Term -import Expect -import Test exposing (..) - - -parseTests : Test -parseTests = - describe "parse" - [ describe "success" - [ test "a fact" <| - \_ -> - Expect.equal - (Ok (unsafeProgram [ Rule.fact (Atom.atom "greek" [ Term.string "Socrates" ]) ])) - (parse "greek(\"Socrates\").") - , test "a fact with leading space" <| - \_ -> - Expect.equal - (Ok (unsafeProgram [ Rule.fact (Atom.atom "greek" [ Term.string "Socrates" ]) ])) - (parse " greek(\"Socrates\").") - , test "a fact with a number" <| - \_ -> - Expect.equal - (Ok (unsafeProgram [ Rule.fact (Atom.atom "theAnswer" [ Term.int 42 ]) ])) - (parse "theAnswer(42).") - , test "a rule with a variable" <| - \_ -> - Expect.equal - (Ok - (unsafeProgram - [ Rule.rule - (Atom.atom "mortal" [ Term.variable "whom" ]) - [ positive (Atom.atom "greek" [ Term.variable "whom" ]) ] - ] - ) - ) - (parse "mortal(whom) :- greek(whom).") - , test "a rule with multiple clauses" <| - \_ -> - Expect.equal - (Ok - (unsafeProgram - [ Rule.rule - (Atom.atom "ancestor" [ Term.variable "Child", Term.variable "Ancestor" ]) - [ positive (Atom.atom "parent" [ Term.variable "Child", Term.variable "Parent" ]) - , positive (Atom.atom "ancestor" [ Term.variable "Parent", Term.variable "Ancestor" ]) - ] - ] - ) - ) - (parse "ancestor(Child, Ancestor) :- parent(Child, Parent), ancestor(Parent, Ancestor).") - , test "a program with multiple rules" <| - \_ -> - Expect.equal - (Ok - (unsafeProgram - [ Rule.fact (Atom.atom "greek" [ Term.string "Socrates" ]) - , Rule.rule - (Atom.atom "mortal" [ Term.variable "Whom" ]) - [ positive (Atom.atom "greek" [ Term.variable "Whom" ]) ] - ] - ) - ) - (parse "greek(\"Socrates\").\nmortal(Whom) :- greek(Whom).") - , test "a program with whitespace between rules" <| - \_ -> - Expect.equal - (Ok - (unsafeProgram - [ Rule.fact (Atom.atom "greek" [ Term.string "Socrates" ]) - , Rule.rule - (Atom.atom "mortal" [ Term.variable "Whom" ]) - [ positive (Atom.atom "greek" [ Term.variable "Whom" ]) ] - ] - ) - ) - (parse "greek(\"Socrates\").\n\nmortal(Whom) :- greek(Whom).") - , test "a rule with newlines in between body atoms" <| - \_ -> - Expect.equal - (Ok - (unsafeProgram - [ Rule.rule - (Atom.atom "ancestor" [ Term.variable "Child", Term.variable "Ancestor" ]) - [ positive (Atom.atom "parent" [ Term.variable "Child", Term.variable "Parent" ]) - , positive (Atom.atom "ancestor" [ Term.variable "Parent", Term.variable "Ancestor" ]) - ] - ] - ) - ) - (parse "ancestor(Child, Ancestor) :-\n parent(Child, Parent),\n ancestor(Parent, Ancestor).") - , test "a rule using anonymous variables" <| - \_ -> - Expect.equal - (Ok - (unsafeProgram - [ Rule.rule - (Atom.atom "iceCream" [ Term.variable "favoriteFlavor" ]) - [ positive (Atom.atom "person" [ Term.anonymous, Term.variable "favoriteFlavor" ]) ] - ] - ) - ) - (parse "iceCream(favoriteFlavor) :- person(_, favoriteFlavor).") - , test "a rule using negation in a body atom" <| - \_ -> - Expect.equal - (Ok - (unsafeProgram - [ Rule.rule - (Atom.atom "ancestor" [ Term.variable "Child", Term.variable "Parent" ]) - [ positive (Atom.atom "parent" [ Term.variable "Child", Term.variable "Parent" ]) - , negative (Atom.atom "samePerson" [ Term.variable "Child", Term.variable "Parent" ]) - ] - ] - ) - ) - (parse "ancestor(Child, Parent) :- parent(Child, Parent), not samePerson(Child, Parent).") - , test "a line comment on a separate line" <| - \_ -> Expect.ok (parse "-- this is a comment") - , test "a line comment after a fact" <| - \_ -> Expect.ok (parse "greek(\"Socrates\"). -- lol classic Socrates") - , test "a line comment ater a rule" <| - \_ -> Expect.ok (parse "mortal(thing) :- greek(thing). -- wow, profound") - , test "a line comment between the body atoms in a rule" <| - \_ -> Expect.ok (parse "mortal(thing) :- -- just hanging out you know?\n greek(thing).") - ] - , describe "failure" - [ test "leaving the terms off an atom is not allowed" <| - \_ -> Expect.err (parse "greek") - , test "leaving the closing quote off a constant is not allowed" <| - \_ -> Expect.err (parse "greek(\"Socrates") - , test "leaving the closing parenthesis off a term list is not allowed" <| - \_ -> Expect.err (parse "greek(\"Socrates\"") - , test "leaving a period off a fact is not allowed" <| - \_ -> Expect.err (parse "greek(\"Socrates\")") - , test "adding a trailing comma in a term list is not allowed" <| - \_ -> Expect.err (parse "greek(\"Socrates\",)") - , test "having an implies horn but no body is not allowed" <| - \_ -> Expect.err (parse "mortal(whom) :-") - , test "having a trailing comma in a rule body is not allowed" <| - \_ -> Expect.err (parse "ancestor(Child, Ancestor) :- parent(Child, Parent),") - , test "leaving a period off a rule is not allowed" <| - \_ -> Expect.err (parse "mortal(Whom) :- greek(Whom)") - , test "entering a non-range-restricted rules is not allowed" <| - \_ -> Expect.err (parse "mortal(unused) :- greek(\"Socrates\").") - ] - ] - - -unsafeProgram : List (Result x Rule) -> Datalog.Program -unsafeProgram questionableRules = - let - rulesOrCrash = - List.filterMap - (\res -> - case res of - Ok cool -> - Just cool - - Err err -> - Debug.todo (Debug.toString err) - ) - questionableRules - in - case program rulesOrCrash of - Ok program_ -> - program_ - - Err err -> - Debug.todo (Debug.toString err) diff --git a/tests/Datalog/RuleTests.elm b/tests/Datalog/RuleTests.elm deleted file mode 100644 index 94ab1dd..0000000 --- a/tests/Datalog/RuleTests.elm +++ /dev/null @@ -1,73 +0,0 @@ -module Datalog.RuleTests exposing (..) - -import Datalog.Atom exposing (atom) -import Datalog.Negatable as Negatable exposing (negative, positive) -import Datalog.Rule exposing (..) -import Datalog.Term exposing (anonymous, int, string, variable) -import Expect -import Test exposing (..) - - -ruleTest : Test -ruleTest = - describe "rule" - [ test "a range-restricted rule is allowed" <| - \_ -> - rule - (atom "mortal" [ variable "whom" ]) - [ positive (atom "greek" [ variable "whom" ]) ] - |> Expect.ok - , test "a non-range-restricted rule is not allowed" <| - \_ -> - rule - (atom "mortal" [ variable "whom" ]) - [] - |> Expect.equal (Err NotRangeRestricted) - , test "anonymous terms are not allowed in the head" <| - \_ -> - rule - (atom "mortal" [ anonymous ]) - [ positive (atom "greek" [ anonymous ]) ] - |> Expect.equal (Err UnnamedHeadVariable) - , test "negative terms are allowed if they also appear in a positive form" <| - \_ -> - rule - (atom "unreachable" [ variable "a", variable "b" ]) - [ positive (atom "node" [ variable "a" ]) - , positive (atom "node" [ variable "b" ]) - , negative (atom "reachable" [ variable "a", variable "b" ]) - ] - |> Expect.ok - , test "negative terms which are introduced outside the head are still allowed if they appear in positive form" <| - \_ -> - rule - (atom "peopleWithoutEmails" [ variable "Name" ]) - [ positive (atom "people" [ variable "Id", variable "Name" ]) - , negative (atom "peopleToEmails" [ variable "Id", anonymous ]) - ] - |> Expect.ok - , test "negative terms are not allowed if they don't also appear in a positive form" <| - \_ -> - rule - (atom "immortal" [ variable "whom" ]) - [ negative (atom "mortal" [ variable "whom" ]) ] - |> Expect.equal (Err VariableAppearsNegatedButNotPositive) - ] - - -factTest : Test -factTest = - describe "fact" - [ test "a fact with all concrete terms is allowed" <| - \_ -> - fact (atom "age" [ string "Socrates", int 2490 ]) - |> Expect.ok - , test "a fact with a named variable is not allowed" <| - \_ -> - fact (atom "notGreat" [ variable "unbound" ]) - |> Expect.equal (Err NotRangeRestricted) - , test "a fact with an anonymous variable is not allowed" <| - \_ -> - fact (atom "notGreat" [ anonymous ]) - |> Expect.equal (Err UnnamedHeadVariable) - ] diff --git a/tests/Datalog/TermTests.elm b/tests/Datalog/TermTests.elm deleted file mode 100644 index 13cfe82..0000000 --- a/tests/Datalog/TermTests.elm +++ /dev/null @@ -1,17 +0,0 @@ -module Datalog.TermTests exposing (..) - -import Datalog.Term exposing (..) -import Expect -import Test exposing (..) - - -isGroundTest : Test -isGroundTest = - describe "term isGround" - [ test "a string is ground" <| - \_ -> string "a" |> isGround |> Expect.equal True - , test "an integer is ground" <| - \_ -> int 1 |> isGround |> Expect.equal True - , test "a variable is not ground" <| - \_ -> variable "X" |> isGround |> Expect.equal False - ] diff --git a/tests/DatalogTests.elm b/tests/DatalogTests.elm deleted file mode 100644 index 62e5712..0000000 --- a/tests/DatalogTests.elm +++ /dev/null @@ -1,249 +0,0 @@ -module DatalogTests exposing (..) - -import Datalog exposing (..) -import Datalog.Atom as Atom exposing (Atom, atom) -import Datalog.Negatable as Negatable exposing (Negatable, negative, positive) -import Datalog.Rule as Rule exposing (Rule) -import Datalog.Term as Term exposing (anonymous, string, variable) -import Dict exposing (Dict) -import Expect -import Test exposing (..) - - -solveTest : Test -solveTest = - describe "solve" - [ test "ground rules are solved" <| - \_ -> - unsafeProgram - [ Rule.fact (atom "greek" [ string "Socrates" ]) ] - |> solve - |> get ( "greek", 1 ) - |> Expect.equal [ atom "greek" [ string "Socrates" ] ] - , test "non-ground rules are solved" <| - \_ -> - unsafeProgram - [ Rule.fact (atom "greek" [ string "Socrates" ]) - , Rule.rule - (atom "mortal" [ variable "Whom" ]) - [ positive (atom "greek" [ variable "Whom" ]) ] - ] - |> solve - |> get ( "mortal", 1 ) - |> Expect.equal [ atom "mortal" [ string "Socrates" ] ] - , test "recursive rules are solved" <| - \_ -> - unsafeProgram - [ Rule.fact (atom "link" [ string "a", string "b" ]) - , Rule.fact (atom "link" [ string "b", string "c" ]) - - -- the rule - , Rule.rule - (atom "reachable" [ variable "X", variable "Y" ]) - [ positive (atom "link" [ variable "X", variable "Y" ]) ] - , Rule.rule - (atom "reachable" [ variable "X", variable "Z" ]) - [ positive (atom "link" [ variable "X", variable "Y" ]) - , positive (atom "reachable" [ variable "Y", variable "Z" ]) - ] - ] - |> solve - |> get ( "reachable", 2 ) - |> Expect.equal - [ atom "reachable" [ string "a", string "c" ] - , atom "reachable" [ string "b", string "c" ] - , atom "reachable" [ string "a", string "b" ] - ] - , test "can solve all-pairs reachability" <| - \_ -> - solve allPairsReachability - |> get ( "query", 1 ) - |> Expect.equal - [ atom "query" [ string "d" ] - , atom "query" [ string "c" ] - , atom "query" [ string "b" ] - ] - , describe "negation" - [ test "simple (semipositive) negation" <| - \_ -> - unsafeProgram - [ Rule.fact (atom "link" [ string "a", string "b" ]) - , Rule.fact (atom "link" [ string "b", string "c" ]) - , Rule.fact (atom "link" [ string "c", string "c" ]) - - -- node - , Rule.rule (atom "node" [ variable "name" ]) - [ positive (atom "link" [ variable "name", anonymous ]) ] - , Rule.rule (atom "node" [ variable "name" ]) - [ positive (atom "link" [ anonymous, variable "name" ]) ] - - -- the thing with negation - , Rule.rule (atom "disconnected" [ variable "x", variable "y" ]) - [ positive (atom "node" [ variable "x" ]) - , positive (atom "node" [ variable "y" ]) - , negative (atom "link" [ variable "x", variable "y" ]) - ] - ] - |> solve - |> get ( "disconnected", 2 ) - |> Expect.equal - [ atom "disconnected" [ string "c", string "b" ] - , atom "disconnected" [ string "c", string "a" ] - , atom "disconnected" [ string "b", string "b" ] - , atom "disconnected" [ string "b", string "a" ] - , atom "disconnected" [ string "a", string "c" ] - , atom "disconnected" [ string "a", string "a" ] - ] - , test "siblings example" <| - \_ -> - unsafeProgram - [ Rule.fact (atom "parent" [ string "Child A", string "Parent" ]) - , Rule.fact (atom "parent" [ string "Child B", string "Parent" ]) - - -- helper for negation - , Rule.rule - (atom "samePerson" [ variable "name", variable "name" ]) - [ positive (atom "parent" [ variable "name", anonymous ]) ] - , Rule.rule - (atom "samePerson" [ variable "name", variable "name" ]) - [ positive (atom "parent" [ anonymous, variable "name" ]) ] - - -- now the actual rule - , Rule.rule - (atom "siblings" [ variable "person", variable "sibling" ]) - [ positive (atom "parent" [ variable "person", variable "parent" ]) - , positive (atom "parent" [ variable "sibling", variable "parent" ]) - , negative (atom "samePerson" [ variable "person", variable "sibling" ]) - ] - ] - |> solve - |> get ( "siblings", 2 ) - |> Expect.equal - [ atom "siblings" [ string "Child B", string "Child A" ] - , atom "siblings" [ string "Child A", string "Child B" ] - ] - , test "stratifies a stratifiable program" <| - \_ -> - unsafeProgram - [ Rule.fact (atom "link" [ string "a", string "b" ]) - , Rule.fact (atom "link" [ string "b", string "c" ]) - , Rule.fact (atom "link" [ string "c", string "c" ]) - , Rule.fact (atom "link" [ string "c", string "d" ]) - - -- reachable - , Rule.rule (atom "reachable" [ variable "a", variable "b" ]) - [ positive (atom "link" [ variable "a", variable "b" ]) ] - , Rule.rule (atom "reachable" [ variable "a", variable "c" ]) - [ positive (atom "link" [ variable "a", variable "b" ]) - , positive (atom "reachable" [ variable "b", variable "c" ]) - ] - - -- node - , Rule.rule (atom "node" [ variable "a" ]) - [ positive (atom "link" [ variable "a", anonymous ]) ] - , Rule.rule (atom "node" [ variable "a" ]) - [ positive (atom "link" [ anonymous, variable "a" ]) ] - - -- unreachable - , Rule.rule (atom "unreachable" [ variable "a", variable "b" ]) - [ positive (atom "node" [ variable "a" ]) - , positive (atom "node" [ variable "b" ]) - , negative (atom "reachable" [ variable "a", variable "b" ]) - ] - ] - |> solve - |> get ( "unreachable", 2 ) - |> Expect.equal - [ atom "unreachable" [ string "d", string "d" ] - , atom "unreachable" [ string "d", string "c" ] - , atom "unreachable" [ string "d", string "b" ] - , atom "unreachable" [ string "d", string "a" ] - , atom "unreachable" [ string "c", string "b" ] - , atom "unreachable" [ string "c", string "a" ] - , atom "unreachable" [ string "b", string "b" ] - , atom "unreachable" [ string "b", string "a" ] - , atom "unreachable" [ string "a", string "a" ] - ] - , test "does not stratify an unstratifiable program" <| - \_ -> - [ Rule.rule (atom "p" [ variable "x" ]) - [ positive (atom "exists" [ variable "x" ]) - , negative (atom "q" [ variable "x" ]) - ] - , Rule.rule (atom "q" [ variable "x" ]) - [ positive (atom "exists" [ variable "x" ]) - , negative (atom "p" [ variable "x" ]) - ] - ] - |> List.map - (\ruleOrErr -> - case ruleOrErr of - Ok rule -> - rule - - Err err -> - Debug.todo (Debug.toString err) - ) - |> program - |> Expect.equal (Err Datalog.CycleWithNegation) - ] - ] - - -{-| All-pairs reachability example from Datalog and Recursive Query -Programming. --} -allPairsReachability : Datalog.Program -allPairsReachability = - unsafeProgram - [ -- base data - Rule.fact (atom "link" [ string "a", string "b" ]) - , Rule.fact (atom "link" [ string "b", string "c" ]) - , Rule.fact (atom "link" [ string "c", string "c" ]) - , Rule.fact (atom "link" [ string "c", string "d" ]) - - -- recursive rule - , Rule.rule - (atom "reachable" [ variable "X", variable "Y" ]) - [ positive (atom "link" [ variable "X", variable "Y" ]) ] - , Rule.rule - (atom "reachable" [ variable "X", variable "Y" ]) - [ positive (atom "link" [ variable "X", variable "Z" ]) - , positive (atom "reachable" [ variable "Z", variable "Y" ]) - ] - - -- query - , Rule.rule - (atom "query" [ variable "X" ]) - [ positive (atom "reachable" [ variable "a", variable "X" ]) ] - ] - - -get : ( String, Int ) -> Dict ( String, Int ) ( a, List a ) -> List a -get key dict = - Dict.get key dict - |> Maybe.map (\( first, rest ) -> first :: rest) - |> Maybe.withDefault [] - - -unsafeProgram : List (Result x Rule) -> Datalog.Program -unsafeProgram questionableRules = - let - rulesOrCrash = - List.filterMap - (\res -> - case res of - Ok cool -> - Just cool - - Err err -> - Debug.todo (Debug.toString err) - ) - questionableRules - in - case program rulesOrCrash of - Ok program_ -> - program_ - - Err err -> - Debug.todo (Debug.toString err)