├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── WRITEUP.md ├── app └── Main.hs ├── factorial.pl ├── minilog.cabal ├── natural.pl └── src ├── Evaluate ├── State.hs └── Step.hs ├── Lexer.x ├── Parser.y ├── Term.hs └── Token.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for minilog 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022 lambduli 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Minilog 2 | 3 | Minilog is a very small programming language implementation. 4 | It's goal is to capture the essence of logic programming. 5 | 6 | > For the implementation write up see: [the write up](./WRITEUP.md). 7 | 8 | It is very much a subset of Prolog, at least in terms of the syntax. 9 | The biggest (intended) difference in terms of a runtime behaviour is the strict 10 | `occurs` checking. 11 | Unlike Prolog, Minilog does not accept infinite terms. 12 | 13 | This means that the following snippet will succeed in Prolog but not in Minilog: 14 | 15 | ```prolog 16 | X = foo(X). 17 | ``` 18 | 19 | ## Syntax 20 | As stated above, Minilog's syntax is a subset of the syntax of Prolog. 21 | In Minilog you have: 22 | 23 | - Atoms 24 | 25 | `foo`, `z` 26 | 27 | - Variables 28 | 29 | `X`, `Y` 30 | - Wildcards 31 | 32 | `_` 33 | - Structs 34 | 35 | `foo(X, thing)` 36 | 37 | - Facts 38 | 39 | `plus(z, N, N).` 40 | 41 | - Rules 42 | 43 | `plus(s(N), M, s(R)) :- plus(N, M, R).` 44 | 45 | - Conjunctions 46 | 47 | `times(N, M, R), plus(R, M, A).` 48 | 49 | - Unification Operator 50 | 51 | `X = something` 52 | 53 | ---- 54 | 55 | Here is an example of a valid Minilog knowledge base definition: 56 | ```prolog 57 | plus(z, N, N). 58 | plus(s(N), M, s(R)) :- plus(N, M, R). 59 | 60 | times(z, _, z). 61 | times(s(N), M, A) :- times(N, M, R), plus(R, M, A). 62 | 63 | fact(z, s(z)). 64 | fact(s(N), R) :- fact(N, PR), times(s(N), PR, R). 65 | ``` 66 | 67 | And here is an example of a valid query: 68 | ```prolog 69 | ?- fact(A, B) , plus(A,B, s(s(z))) . 70 | ``` 71 | 72 | --- 73 | 74 | ## What is not in Minilog? 75 | 76 | - numbers 77 | - arithmetics (obviously) 78 | - strings 79 | - explicit or (`;`) 80 | - cuts (`!`) 81 | 82 | ## What is it for? 83 | 84 | The implementation is just a complement of the [write up](./WRITEUP.md). 85 | The goal of this project is to offer an introductory level almost tutorial-like description of an implementation of a simple abstract machine for a logic language. 86 | 87 | The design of the implementation is not aming to represent a practical implementation of a logic programming language. 88 | It should not be considered more than an initial exposition to the ideas behind concepts like 89 | unification, proof search that happens during the evaluation and a backtracking in such a proof search. 90 | 91 | You could also say that the design of the implementation was chosen to be observable by default. Indeed, as the runtime is implemented 92 | as a simple "stepping" interpreter, we can very much see "inside" the process. 93 | The write up goes into more detail on that topic. 94 | 95 | The goal of the project is not to be a rigorous introduction into the matter! At best it should serve as a toy-like demonstration; similar to when a math or physics teacher reaches for a vast (but still valid) simplification to make some complicated sounding concept more approachable. 96 | 97 | 98 | ## How can you use it? 99 | 100 | 1) You run `cabal build` and if that succeeded `cabal run`. 101 | 102 | 2) You can use the knowledge base in the repository, modify it, or use your own. It is loaded into the repl using a command `:load ` like `:load factorial.pl`. 103 | 104 | 3) You write Prolog-like query and hit enter. 105 | 106 | 4) When presented with a result, you either write `:next` and hit enter (to backtrack) or you write `:done` and hit enter to conclude the computation. 107 | 108 | 5) When you want to quit the REPL, you submit `:q` or `:Q`. 109 | -------------------------------------------------------------------------------- /WRITEUP.md: -------------------------------------------------------------------------------- 1 | # Implementing Relational Language 2 | 3 | In its essence the implementation of a simple relational/logic programming language really consists of only a few basic concepts. 4 | 5 | Our implementation will not use techniques from the real-world. This very much means that the *real* implementation of such a language, one that could be used for solving real tasks, should not be implemented with such a design. 6 | 7 | This write up describes a simple *abstract machine*. One that can be implemented on less than 300 lines of code in any practical language. 8 | While the main focus of the design is not efficiency and near-native speed, our implementation will be able to compute factorial of 7 in just a little above 20 seconds. That is, of course, with our own natural number representation. 9 | 10 | For more information on real-world implementation of logic programming langauges see [Warren Abstract Machine](https://en.wikipedia.org/wiki/Warren_Abstract_Machine). 11 | 12 | > This write up expects the reader to have been exposed to a language like [Prolog](https://en.wikipedia.org/wiki/Prolog). No advance knowledge of Prolog or logic programming is required - only a level that can be obtained in a couple of hours on the internet. 13 | 14 | ---- 15 | 16 | ### [Peano Numbers](https://wiki.haskell.org/Peano_numbers) 17 | 18 | We use a representation of Natural Numbers that consists of two constructs - an atom for zero, called `z`, and a functor `s/1` for a successor of any natural number. 19 | 20 | Here is a showcase that speaks for itself: 21 | 22 | 0 := `z` 23 | 24 | 1 := `s(z)` 25 | 26 | 2 := `s(s(z))` 27 | 28 | 3 := `s(s(s(z)))` 29 | 30 | ... 31 | 32 | ---- 33 | 34 | ## Leading Example 35 | 36 | Let us start with a simple example of a Minilog program: 37 | ```prolog 38 | plus(z, N, N). 39 | plus(s(N), M, s(R)) :- plus(N, M, R). 40 | ``` 41 | 42 | > Those two predicates describe addition operation on our representation of natural numbers. 43 | > Adding any number to zero equals to that original number and adding a non-zero number to anything is equal to adding a number one-smaller to that anything plus one. 44 | 45 | Now suppose that we want to prove a query `plus(A, B, B)`. 46 | 47 | > This reads: "What are two natural numbers whose sum is equal to the second one?" 48 | 49 | Were we do that manually on a piece of paper with a pen, it might look something like this: 50 | 51 | ---- 52 | 1) We start by writing down our *goal*: 53 | ```prolog 54 | plus(A, B, B) 55 | ``` 56 | 57 | 2) Now we start looking for a predicate in the base that has the same name and arity as our goal. The first one fits that description so we try to unify our goal with the head of that predicate. We replace our current goal with a new one: 58 | ```prolog 59 | plus(A, B, B) = plus(z, N, N) 60 | ``` 61 | 62 | 3) This can be done through *decomposition*. We break down the current goal into three smaller pieces: 63 | ```prolog 64 | A = z 65 | B = N 66 | B = N 67 | ``` 68 | 69 | 4) We now have three *unification* goals. Let us start with the one at the top and observe that it is technically an *assignment*. We record this new information on the side of the paper (in our case - we just write it down) and discharge the *sub-goal*: 70 | 71 | Assignments: `A = z`. 72 | 73 | ```prolog 74 | B = N 75 | B = N 76 | ``` 77 | 78 | 5) We now have two identical sub-goals. We will save us some work and discharge both of them at the same time. The same as above, we just write it down: 79 | 80 | Assignments: `A = z`, `B = N`. 81 | 82 | 6) With that, we have got rid of all the goals. This means that our initial goal `plus(A, B, B)` can be satisfied when `A` is `z` and `B` is anything at all. (Because neither `B` nor `N` are assigned a concrete value.) 83 | 84 | ---- 85 | 86 | We are not done yet, however! One of the key features of logic langauges is the backtracking. This means we need to go back a little and see if we can satisfy the same goal in a different way. We need to do this for all potential paths through the *proof space*. 87 | 88 | We go back to the step `2` and take an alternative path this time around. 89 | 90 | 2) We keep looking for a predicate in the base that has the same name and arity as our goal. The second one fits that description too, so we try to unify our goal with the head of that predicate. On top of that, we also take the goal in the *rule*'s body and add it to our collection of goals: 91 | ```prolog 92 | plus(A, B, B) = plus(s(N), M, s(R)) 93 | plus(N, M, R) 94 | ``` 95 | 96 | 3) Once again, we decompose the unification goal at the top: 97 | ```prolog 98 | A = s(N) 99 | B = M 100 | B = s(R) 101 | plus(N, M, R) 102 | ``` 103 | 104 | 4) The next sub-goal goes stright into the "environment" part of our papers/text files: 105 | 106 | Assignments: `A = s(N)`. 107 | 108 | ```prolog 109 | B = M 110 | B = s(R) 111 | plus(N, M, R) 112 | ``` 113 | 5) The two following goals are clearly related to each other. Both look like a simple assignment on their own, but both are assigning to `B`. We do not mind that in the slightest. The assignment will just look a little bit more complicated: 114 | 115 | Assignments: `A = s(N)`, `B = M = s(R)`. 116 | 117 | ```prolog 118 | plus(N, M, R) 119 | ``` 120 | 121 | 6) For our current goal we, once again, turn our attention to the base and search for a fitting predicate. We try the first one again. This time around, however, we need to do some "bookkeeping" so that our names do not get tangled: 122 | 123 | Assignments: `A = s(N)`, `B = M = s(R)`. 124 | 125 | ```prolog 126 | plus(N, M, R) = plus(z, N1, N1) 127 | ``` 128 | 129 | 7) We decompose again: 130 | 131 | Assignments: `A = s(N)`, `B = M = s(R)`. 132 | 133 | ```prolog 134 | N = z 135 | M = N1 136 | R = N1 137 | ``` 138 | 139 | 8) We extend the assignments: 140 | 141 | Assignments: `A = s(N)`, `B = M = s(R)`, `N = z`. 142 | 143 | ```prolog 144 | M = N1 145 | R = N1 146 | ``` 147 | 148 | 9) We do it again: 149 | 150 | Assignments: `A = s(N)`, `B = M = N1 = s(R)`, `N = z`. 151 | 152 | ```prolog 153 | R = N1 154 | ``` 155 | 156 | 10) And now again: 157 | 158 | Assignments: `A = s(N)`, `B = M = N1 = R = s(R)`, `N = z`. 159 | 160 | ---- 161 | 162 | The keen eyed reader should be able to observe that we have introduced a sort of a cycle between `R` and its assigned "value". Indeed, `R` is assigned a term of the shape `s(R)`. This very much means that `R` is defined in terms of itself. 163 | 164 | In Prolog, this is allowed by default. Not so much in Minilog. Any attempt to introduce this sort of a cycle results in a failure of the process. 165 | 166 | So we need to backtrack again. This time we go back to the step `6` and take yet another path: 167 | 168 | 6) We now try the second one again. We need to do some "bookkeeping" as well: 169 | 170 | Assignments: `A = s(N)`, `B = M = s(R)`. 171 | 172 | ```prolog 173 | plus(N, M, R) = plus(s(N1), M1, s(R1)) 174 | plus(N1, M1, R1) 175 | ``` 176 | 177 | 7) We decompose again: 178 | 179 | Assignments: `A = s(N)`, `B = M = s(R)`. 180 | 181 | ```prolog 182 | N = s(N1) 183 | M = M1 184 | R = s(R1) 185 | plus(N1, M1, R1) 186 | ``` 187 | 188 | 8) We can fast forward through the next three sub-goals: 189 | 190 | Assignments: `A = s(N)`, `B = M = M1 = s(R)`, `N = s(N1)`, `R = s(R1)`. 191 | 192 | ```prolog 193 | plus(N1, M1, R1) 194 | ``` 195 | 196 | ---- 197 | 198 | We could go on and keep evaluating, but that would not lead to anything useful. From now on, the process goes on for ever. 199 | The last goal above is equivalent to `plus(N1, s(s(R1)), R1)`. 200 | 201 | We could read it as: "Which two natural numbers (where the second one is not smaller than `2`), when added together add up to a difference between the second one and number `3`. 202 | 203 | The answer is `None!` - there is no way to add two natural numbers together and end up with a result smaller than one of those numbers. 204 | 205 | The fact that the process diverges at this point, is a direct consequence of the search strategy Prolog and by extension Minilog uses - the [Depth First Search](https://en.wikipedia.org/wiki/Depth-first_search). 206 | 207 | 208 | ---- 209 | 210 | We now turn our attention to the strategy that we have used in the process above. 211 | The idea was to carry around an environment recording assignments of variables. 212 | 213 | This strategy is not inherently bad, it would work not only on paper but also as an underlying design for our *abstract machine*. It would have a couple of strong drawbacks, however. It would not be very efficient and the implementation would be a bit more involved than we would expect from a **simple** *abstract machine*. 214 | 215 | As a bonus, this approach gets quite unwieldy quite quick. 216 | 217 | For those reasons we leave this strategy behind and focus on a much more tractable one. 218 | 219 | Instead of recording those assignments in an environment, we apply them immediatelly like they are some sort of a substitutition. To be more specific, any time we have a sequence of goals and the top one is in the shape ` = `, we treat it as a substitution and apply it to the rest of the goals. 220 | 221 | This approach is part of the algorithm for unification introduced by [Martelli and Montanari](https://dl.acm.org/doi/10.1145/357162.357169). 222 | It is also nicely summed up in this [wikipedia article](https://en.wikipedia.org/wiki/Unification_(computer_science)#A_unification_algorithm). 223 | 224 | We will get back to it in later sections. 225 | 226 | 227 | ---- 228 | ## Representation of Terms 229 | 230 | This section describes our way of representing terms and other syntactic forms of our langauge as simple Haskell data structures. 231 | 232 | ### Basic Terms 233 | 234 | #### Atoms 235 | 236 | Representing *atoms* is going to be trivial. The only thing that needs to be stored is the atom's name. 237 | 238 | #### Variables 239 | 240 | The situation is very similar when it comes to *variables*. Once again, we only need to keep around the name of the variable. 241 | 242 | #### Compound Terms/Structs 243 | 244 | In Minilog, as well as in Prolog, we have a notion of compound terms. People sometimes call them structs. They consist of a functor (a name of the sort of a "constructor") and a parenthesized list of terms delimited with a comma between them. 245 | 246 | The `foo(something, B)` is a compound term/struct. The `foo` is the functor and `something` and `B` are the terms "stored" in the "structure". 247 | 248 | #### Wildcard `_` 249 | 250 | The simplest of all the terms is a wildcard/hole. It behaves similarly to a variable. The only exception is that it can never be referenced again, it serves only as a sink hole for anything. Despite that, or rather precisely for that, it can be quite usefull! 251 | 252 | ---- 253 | 254 | We could represent our notion of a *term* as a following Haskell data structure: 255 | ```haskell 256 | data Term = Var String 257 | | Atom String 258 | | Compound Struct 259 | | Wildcard 260 | 261 | data Struct = Struct{ name :: String, args :: [Term] } 262 | ``` 263 | Alternatively, we can express it with a simple grammar: 264 | ``` 265 | Term := Var 266 | | Atom 267 | | Struct 268 | | '_' 269 | 270 | Var := [A-Z]([A-Z][a-z])* 271 | 272 | Atom := [a-z]([A-Z][a-z])* 273 | 274 | Struct := Atom '(' Terms ')' 275 | 276 | Terms := Term 277 | | Term ',' Terms 278 | ``` 279 | 280 | ---- 281 | 282 | ### Predicates 283 | 284 | What we call a *predicate* is a bit more complicated form in the language. It is a way to define new relations. Our knowledge base will consist of many such predicates. 285 | 286 | A *Predicate* is either a *Fact* or a *Rule*. 287 | 288 | #### Facts 289 | 290 | A fact is syntactically very simple. It is predicate that does not have a body, only the head. 291 | For example, `id(I, I).` is a fact. 292 | 293 | We can observe that a fact is very similar to a compound term with the only difference being the fact that a *fact* is a "sort of a declaration" and as such it is always followed by a period. 294 | 295 | In any case, we can take advantage of that similarity when representing predicates in our implementation. 296 | 297 | #### Rules 298 | 299 | Rules are a little bit more complicated. They consist of two parts delimited by a symbol `:-`. The part on the left is basically a *fact* while the part on the right is called a *body*. The body of the rule is simply a non-empty list of *goals* separated by a comma (`,`) which means **AND** in Prolog. 300 | 301 | We will cover what exactly the *goal* is later. For now, we just say that the body might be a single *predicate call* or a *conjunction* of those. 302 | 303 | ### Goals 304 | 305 | We have mentioned the *goals* above. What we mean when we say that something is a goal is that it is a *term* that is understood as a proposition. Simply put, when we write the following query: 306 | ```prolog 307 | id(something, A). 308 | ``` 309 | we say that `id(something, A)` is a goal. That is - we want it to be proved or disproved. 310 | 311 | In this sense, bodies of rules are indeed just goals. For the rule to succeed - all the sub-goals in the body need to succeed, assuming that the *head* of the rule was unified with the original goal anyway. 312 | 313 | Here is an example to further the point: 314 | ```prolog 315 | ... 316 | 317 | is_nice_color(X) :- is_color(X), is_nice(X) . 318 | ``` 319 | When we ask the query `is_nice_color(red)`, we can see how that query is considered a goal and how the body of our rule is considered a sequence of goals too. 320 | 321 | 322 | ---- 323 | 324 | We can represent predicates and goals as the following Haskell data structures: 325 | ```haskell 326 | data Goal = Call Struct 327 | | Unify Term Term 328 | 329 | data Predicate = Fact Struct 330 | | Struct :- [Goal] 331 | ``` 332 | > Note about Goal: We will explain its two variants in greater detail in later sections about evaluation. 333 | 334 | > Note about syntax: We have used an infix constructor `(:-)` to represent rules. 335 | 336 | Alternatively, we can express it with a simple grammar: 337 | ``` 338 | Goal := Struct 339 | | Term '=' Term 340 | 341 | Predicate := Struct '.' 342 | | Struct ':-' Body 343 | 344 | Body := Goals '.' 345 | 346 | Goals := Goal 347 | | Goal ',' Goals 348 | ``` 349 | 350 | ---- 351 | 352 | ## Evaluation - Basic Concepts 353 | 354 | We split the whole issue at hand into two parts. 355 | 356 | - unification 357 | - proof search with backtracking 358 | 359 | Those two concepts cover the entirety of the evaluation. 360 | But we have hinted that with our leading example already. 361 | 362 | ### Unification 363 | 364 | In its core, the concept of unification is a really simple one. 365 | 366 | We have two things and we ask whether they can be "the same thing" and what would it take for them to be. 367 | 368 | Here is an example (the operator `=` means `unify with`): 369 | ```prolog 370 | ?- A = something . 371 | ``` 372 | 373 | The result of running such a query in Prolog will, of course, be positive. Simply because a variable like `A`, that is - a fresh one - can be unified with anything at all. 374 | 375 | So maybe a little bit more illustrative example would be: 376 | ```prolog 377 | foo(A, something, X) = foo(whatever, B, B) 378 | ``` 379 | Those two terms can be "the same thing" if `A = whatever` and `B = X = something`. 380 | 381 | 382 | So let us first give a few vague rules for unification before we explore any further: 383 | 384 | - An atom unifies with an identical atom. 385 | - A struct unifies with a struct when they have the same name and the same arity and their arguments unify pairwise. 386 | - A fresh variable unifies with anything. 387 | - A variable that has already been unified with something, unifies with another thing only if the first thing and the new thing unify together. 388 | 389 | This should serve as a mental checkpoint before we go all in on the real algorithm mentioned above. 390 | 391 | --- 392 | 393 | 394 | ### Proof Search with Backtracking 395 | 396 | In this section we are going to explore the concepts of proof search and backtracking very briefly. We will not go into a much detail simply because the key element of our approach will rely on the specific representation of the state of our `machine`. 397 | 398 | #### Proof Search 399 | 400 | The traversal of the state space is quite stright forward. We start with an initial goal and we search for a predicate in our knowledge base that would allow us to prove that goal. 401 | 402 | When we find such a predicate we have to see if our goal can unify with the head of the predicate. If it does and the predicate is a *fact*, we have found a way to satisfy the goal. 403 | If it is *rule* we have to attempt proving the body of the rule. Remember - bodies of rules are just sequences of goals. 404 | 405 | Here is an example demonstrating the point: 406 | ```prolog 407 | ... 408 | 409 | small(mouse). 410 | 411 | small(X) :- small(Y) , at_most_as_big_as(X, Y) . 412 | ``` 413 | 414 | If our initial goal is `small(mouse)` we can see that the first predicate in the base does very much unify with the goal at hand. But as we should already know, the key feature of logic languages is backtracking. 415 | This means that even after the first predicate allows us to satisfy the goal, we still need to try to satisfy it in any other way that is possible. 416 | 417 | The head of the second predicate in the base also matches our goal. 418 | So if we can satisfy the goals that make up its body, we can also prove that `mouse` is `small`. The details of that process very much depend on the specific definition of `at_most_as_big_as` and rest of the definition for `small`. We will leave this example now. 419 | 420 | 421 | ---- 422 | 423 | The description above illustrates one important point - when our goal is a predicate invocation, we can approach satisfying it by viewing the invocation as a struct/compound term and see the heads of predicates the same way. Whenever we can unify those two terms (our goal and a predicate head) we have a potential way to satisfy the goal. 424 | 425 | This is quite important, because it allows us to use unification in this part of the process too. Later it will be aparent just how important and central unification is to the whole process of evaluation - **it is** the thing that does most work for the evaluation. 426 | 427 | ---- 428 | 429 | #### Backtracking 430 | 431 | We have already mentioned backtracking in the previous section. In this section we will discuss it a little bit more. 432 | 433 | We can observe that in our small language backtracking should really only happen when we have a predicate invocation and we are searching for a fitting predicate in the base. We do backtrack by trying **all the fitting** predicates in the base for the current goal. 434 | 435 | There is no more to it than that. So if we are able to come back to a point where we have decided to try the first fitting predicate in the base and try to use another one, we would have a backtracking handled (and again after that one, of course). 436 | 437 | The only viable way to "come back to a past point" in our implementation is to store our machine state (or some relevant parts of it) somewhere until the current path is done being explored. When it eventually succeeds or fails we can "get back" to the stored one - doing backtracking. 438 | 439 | So it all depends on the representation that we chose for our machine state. That is precisely the topic of the next section. 440 | 441 | 442 | ### Machine State Representation 443 | 444 | We want a representation that is explicit enough - does not leave any part of the evaluation to be "implicitly" encoded in the implementation langauge - but is simple enough at the same time. We do not want to use complex data structures making the reasoning about or the re-implementation of Minilog more complicated than it needs to be. 445 | 446 | Fortunately, we will do with just a few basic data types that should be common enough not only to most programming languages but to any of the readers too. 447 | 448 | What our machine state needs to contain: 449 | 450 | - our base 451 | - a position in the base 452 | - a stack of goals to satisfy 453 | - a stack for backtracking 454 | 455 | For the bookkeeping purposes (renaming variables to fresh names) we will also need to carry some increment-only counter. 456 | 457 | And to make the presentation of the success easier we also keep around a mapping from all the variables from the original query to the terms that the evaluation assigned to them. 458 | Thanks to that, the presentation is just a matter of printing all the mappings. 459 | 460 | ---- 461 | 462 | All of this leads to the following Haskell data structure: 463 | ```haskell 464 | data State 465 | = State { base :: [Predicate] 466 | 467 | , position :: Int 468 | , goal'stack :: [Goal] 469 | , backtracking'stack :: [([Goal], Int, Query'Mapping)] 470 | 471 | , counter :: Int 472 | , query'vars :: Query'Mapping } 473 | 474 | type Query'Mapping = Map.Map String Term 475 | ``` 476 | 477 | ---- 478 | 479 | 480 | ### Algorithm 481 | 482 | In this section we give the (almost) full algorithm for the implementation of the machine in a pseudocode. 483 | It is split in two parts, one for unification and one for a single step of the machine evaluation. 484 | 485 | #### Step of the Evaluation 486 | 487 | Here is what the algorithm does on every step: 488 | 489 | ``` 490 | machine state MS consists of: 491 | - a goal stack GS 492 | - a base B 493 | - a position of some predicate in base P 494 | - a backtracking stack BS 495 | 496 | Each step is given a machine state MS and is expected to return a machine state MS'. 497 | ``` 498 | 499 | ``` 500 | on each step do: 501 | - inspect the goal stack GS: 502 | 503 | - on top of the goal stack GS there is a goal G to invoke a predicate, then: 504 | 505 | - starting at the position P, search the base for the first predicate with the same name and arity as G; if: 506 | - we find one, then: 507 | - we check if that predicate is: 508 | - a fact F at the position P_CURRENT, then: 509 | - pop the goal G 510 | - set the position P to 0 511 | - rename all the variables in F to unique names, obtaining F_RENAMED 512 | - create a new goal NG being (G = F1_RENAMED) 513 | - push NG on top of the goal stack. 514 | 515 | 516 | - a rule R at the position P_CURRENT, then: 517 | - pop the goal G 518 | - set the position P to 0 519 | - rename all the variables in the R to unique names, obtaining R_RENAMED 520 | - push each sub-goal in the body of the R_RENAMED on top of the goal stack (first sub-goal in the body goes last) 521 | - create a new goal NG being (G = H_RENAMED) where H_RENAMED is the head of the R_RENAMED 522 | - push NG on top of the goal stack 523 | 524 | - search the base for the next predicate after P_CURRENT, with the same name and arity as G; if: 525 | - there is one at the position P_NEXT, then: 526 | - create a backtracking record BR consisting of the original goal stack GS and a position P_NEXT 527 | - push BR on top of the backtracking stack BS 528 | 529 | - there is none, then we do not change the backtracking stack BS 530 | 531 | - there is no fitting predicate; then: 532 | - we attempt backtracking 533 | 534 | - on top of the goal stack GS there is a goal G to unify two terms; then: 535 | - we use the unification algorithm described below, it results in: 536 | 537 | - a success - it produces a substitution/mapping SUB from variables to terms and a goal stack GS_UNIF, we do: 538 | - apply SUB to GS obtaining a new goal stack GS_SUBSTITUTED 539 | - concatenate GS_UNIF with GS_SUBSTITUTED obtaining GS_NEW 540 | - we set GS to GS_NEW 541 | 542 | - a failure - then we attempt backtracking 543 | 544 | - the goal stack GS is empty; we attempt backtracking. 545 | 546 | 547 | to attempt backtracking: 548 | inspect the backtracking stack BS: 549 | 550 | - on top of the backtracking stack BS there is a backtracking record BR; then: 551 | - set the position to the P_NEXT from the record BR 552 | - set the goal stack to the GS from the record BR 553 | - run a step of the computation 554 | 555 | - the backtracking stack BS is empty; then: 556 | - we fail 557 | ``` 558 | 559 | The algorithm above omits two small details. It does not concern itself with the details of renaming predicates or how should we ensure that we always use a new name. The reader is expected to fill in that themself. The second detail omited is the aforementioned mapping from variables of the original query to the terms to-them-assigned. This is also trivial and should not be a problem for the reader. 560 | 561 | 562 | #### Unification 563 | 564 | The unification algorithm takes two arguments and either succeeds or fails. 565 | If it succeeds, it produces a substitution/mapping from variables to terms and a stack of new goals. 566 | 567 | The following is the algorithm for the unification: 568 | 569 | ``` 570 | two terms unify by these rules: 571 | - unification of two identical terms succeeds with an empty substitution and an empty goal stack 572 | 573 | - unification of two structs S_L and S_R of the same name and the same arity N is done through decomposition: 574 | - for each pair of arguments to S_L and S_R - ARG_L_n and ARG_R_n - we create a new unification goal UG being ARG_L_n = ARG_R_n, together we call it ARG_GS 575 | - we succeed with an empty substitution and a goal stack ARG_GS 576 | 577 | - unification of two structs that do not have the same name and the same arity fails 578 | 579 | - unification of a variable and a term satisfying an occurs check is used as a substitution SUB ( -> ) 580 | - we succeed with a substitution SUB and an empty goal stack 581 | 582 | - unification of a variable and a term failing an occurs check fails 583 | 584 | 585 | occurs check for a variable V and a term T fails when: 586 | - the term T is a compound term with arguments ARGS and for any ARG_n from ARGS the occurs check for V and ARG_n fails 587 | - the term T is a variable equal to the V (the same name) 588 | ``` 589 | 590 | This concludes the writeup. -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List ( foldl', intercalate ) 4 | import Data.List.Extra ( trim ) 5 | 6 | import Data.Map.Strict qualified as Map 7 | import Data.Set qualified as Set 8 | 9 | import System.IO ( hFlush, stdout, openFile, IOMode(ReadMode), hGetContents ) 10 | 11 | 12 | import Term ( Term(..), Struct(..), Predicate(..), Goal(..) ) 13 | 14 | import Evaluate.Step ( step ) 15 | import Evaluate.State ( State(..), Action(..) ) 16 | 17 | import Parser ( parse'base, parse'query ) 18 | 19 | 20 | empty'state :: State 21 | empty'state = State { base = [] 22 | , query'vars = Map.empty 23 | , backtracking'stack = [] 24 | , goal'stack = [] 25 | , position = 0 26 | , counter = 0 } 27 | 28 | 29 | set'goal :: [Goal] -> State -> State 30 | set'goal goals state = state{ query'vars = Map.fromList q'vars 31 | , backtracking'stack = [] 32 | , goal'stack = goals 33 | , position = 0 34 | , counter = 0 } 35 | where 36 | free'names :: [String] 37 | free'names = Set.toList (free'vars'in'query goals) 38 | 39 | free'vars = map Var free'names 40 | 41 | q'vars = zip free'names free'vars 42 | 43 | 44 | load'base :: [Predicate] -> State -> State 45 | load'base base state = state{ base = base 46 | , query'vars = Map.empty 47 | , backtracking'stack = [] 48 | , goal'stack = [] 49 | , position = 0 50 | , counter = 0 } 51 | 52 | 53 | main :: IO () 54 | main = do 55 | putStrLn "Minolog - implementation of simple logic programming language." 56 | repl empty'state 57 | putStrLn "Bye!" 58 | 59 | 60 | repl :: State -> IO () 61 | repl old'state = do 62 | putStr "?- " 63 | hFlush stdout 64 | str <- getLine 65 | case str of 66 | ":q" -> return () 67 | ":Q" -> return () 68 | ':' : 'l' : 'o' : 'a' : 'd' : file'path -> do 69 | file'handle <- openFile (trim file'path) ReadMode 70 | file'content <- hGetContents file'handle 71 | case parse'base file'content of 72 | Left (err, col) -> do 73 | let padding = take (3 + col - 1) $! repeat ' ' 74 | putStrLn $! padding ++ "^" 75 | putStrLn err 76 | repl old'state 77 | Right new'base -> do 78 | let new'state = load'base new'base old'state 79 | repl new'state 80 | 81 | ':' : _ -> do 82 | putStrLn "I don't know this command, sorry." 83 | repl old'state 84 | 85 | _ -> do 86 | case parse'query str of 87 | Left (err, col) -> do 88 | let padding = take (3 + col - 1) $! repeat ' ' 89 | putStrLn $! padding ++ "^" 90 | putStrLn err 91 | repl old'state 92 | Right goals -> do 93 | let new'state = set'goal goals old'state 94 | try'to'prove new'state 95 | 96 | try'to'prove :: State -> IO () 97 | try'to'prove state = do 98 | case step state of 99 | Succeeded s -> do 100 | case step s of 101 | Redoing state' -> do 102 | let q'vars = query'vars s 103 | let result = if Map.null q'vars 104 | then "True" 105 | else intercalate "\n" $! map (\ (k, v) -> k ++ " = " ++ show v) $! Map.toList q'vars 106 | putStrLn result 107 | user'input <- getLine 108 | case user'input of 109 | ":next" -> do 110 | putStrLn " or\n" 111 | try'to'prove state' 112 | ":done" -> do 113 | putStrLn "." 114 | repl state' 115 | _ -> do 116 | putStrLn " or\n" 117 | try'to'prove state' 118 | 119 | Done -> do 120 | let q'vars = query'vars s 121 | let result = if Map.null q'vars 122 | then "True" 123 | else intercalate "\n" $! map (\ (k, v) -> k ++ " = " ++ show v) $! Map.toList q'vars 124 | putStrLn result 125 | repl s 126 | 127 | _ -> error "should never happen" 128 | 129 | -- TODO: wait for the interaction 130 | -- to know whether to attempt backtracking. 131 | -- I should change the step, so that the first two equations are not there 132 | -- another function would do that for me. 133 | -- that would allow me to sort of re-charge the state 134 | -- without misleadingly calling `step` or `try'to'prove` 135 | {- Maybe it is not misleading. Maybe keeping the step's pattern 136 | matching exhaustive is worth it. -} 137 | -- that function would either set me up for backtracking 138 | -- that would be signalized by `Redoing` 139 | -- or it would recognize that there is no way to backtrack 140 | -- so that would be signalized by `Done`. 141 | -- This would have the nice property of me knowing 142 | -- right away, whether I should hang for users's interaction 143 | -- or if I should just put `.` right away. 144 | 145 | Failed -> do 146 | putStrLn "False." 147 | repl state 148 | 149 | Searching s -> do 150 | try'to'prove s 151 | 152 | _ -> error "should never happen" 153 | 154 | 155 | free'vars'in'query :: [Goal] -> Set.Set String 156 | free'vars'in'query goals = foldl' (\ set g -> set `Set.union` free'vars'in'goal g) Set.empty goals 157 | 158 | 159 | free'vars'in'goal :: Goal -> Set.Set String 160 | free'vars'in'goal (Call fun) = free'vars'in'functor fun 161 | free'vars'in'goal (Unify val'l val'r) = Set.union (free'vars'in'val val'l) (free'vars'in'val val'r) 162 | 163 | 164 | free'vars'in'functor :: Struct -> Set.Set String 165 | free'vars'in'functor Struct{ args } = foldl' (\ set g -> set `Set.union` free'vars'in'val g) Set.empty args 166 | 167 | 168 | free'vars'in'val :: Term -> Set.Set String 169 | free'vars'in'val (Var name) = Set.singleton name 170 | free'vars'in'val (Atom _) = Set.empty 171 | free'vars'in'val (Compound fun) = free'vars'in'functor fun 172 | free'vars'in'val Wildcard = Set.empty 173 | -------------------------------------------------------------------------------- /factorial.pl: -------------------------------------------------------------------------------- 1 | plus(z, N, N). 2 | plus(s(N), M, s(R)) :- plus(N, M, R). 3 | times(z, _, z). 4 | times(s(N), M, A) :- times(N, M, R), plus(R, M, A). 5 | fact(z, s(z)). 6 | fact(s(N), R) :- fact(N, PR), times(s(N), PR, R). 7 | -------------------------------------------------------------------------------- /minilog.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: minilog 3 | version: 0.1.0.0 4 | license: MIT 5 | license-file: LICENSE 6 | maintainer: lambduli@gmail.com 7 | author: lambduli 8 | category: Language 9 | build-type: Simple 10 | extra-source-files: 11 | src/Lexer.x 12 | src/Parser.y 13 | 14 | extra-doc-files: CHANGELOG.md 15 | 16 | library 17 | exposed-modules: 18 | Term 19 | Evaluate.State 20 | Evaluate.Step 21 | Token 22 | Lexer 23 | Parser 24 | 25 | build-tool-depends: alex:alex >=3.2.6 && <4.0, happy:happy >=1.20.0 && <2.0 26 | hs-source-dirs: src 27 | default-language: Haskell2010 28 | default-extensions: NamedFieldPuns ImportQualifiedPost BangPatterns 29 | build-depends: 30 | array, 31 | base ^>=4.19.0.0, 32 | containers >=0.6.2.1, 33 | directory, 34 | extra, 35 | filepath, 36 | hspec, 37 | mtl, 38 | transformers, 39 | utf8-string 40 | 41 | executable minilog 42 | main-is: Main.hs 43 | hs-source-dirs: app 44 | default-language: Haskell2010 45 | default-extensions: NamedFieldPuns ImportQualifiedPost BangPatterns 46 | ghc-options: -Wall 47 | build-depends: 48 | minilog, 49 | base ^>=4.19.0.0, 50 | containers >=0.6.2.1, 51 | extra >=1.7.12 52 | -------------------------------------------------------------------------------- /natural.pl: -------------------------------------------------------------------------------- 1 | nat(z). 2 | nat(s(N)) :- nat(N). -------------------------------------------------------------------------------- /src/Evaluate/State.hs: -------------------------------------------------------------------------------- 1 | module Evaluate.State where 2 | 3 | import Data.Map.Strict qualified as Map 4 | import Data.Set qualified as Set 5 | 6 | import Term ( Goal, Term, Predicate ) 7 | 8 | 9 | {- The Action data structure is there 10 | to signalize what happened in the last step -} 11 | data Action a = Succeeded !a 12 | | Failed 13 | | Searching !a 14 | | Redoing !a 15 | | Done 16 | deriving (Eq, Show) 17 | 18 | 19 | data State 20 | = State { base :: ![Predicate] -- knowledge base 21 | , query'vars :: !(Map.Map String Term) -- the variables from the query 22 | , backtracking'stack :: ![([Goal], Int, Map.Map String Term)] 23 | -- a stack of things to try when the current 24 | -- goal fails or succeeds 25 | 26 | , goal'stack :: ![Goal] -- goals to satisfy 27 | , position :: !Int -- position in the base 28 | 29 | , counter :: !Int } -- for renaming variables 30 | deriving (Eq, Show) 31 | 32 | 33 | -- TODO: A new state representation that encodes: 34 | -- Processing a current goal'stack 35 | -- Succeeded - does not contain the goal'stack (I think) 36 | -- Failed - does not contain the goal'stack (might be interesting to think about how to represent what failed and why) 37 | -- 38 | -- The main idea is that there is no Redoing and Done 39 | -- and also the goal'stack is NonEmpty 40 | -- this eliminates the need foor those two equations in `step` 41 | -- because this book keeping will be done in a different function 42 | -- a function that takes a state like Succeeded, one that does not contain a goal'stack 43 | -- and either populates the goal'stack for Processing/Searching or decides that it is Done. 44 | -- This seems like more sensible approach. 45 | -------------------------------------------------------------------------------- /src/Evaluate/Step.hs: -------------------------------------------------------------------------------- 1 | module Evaluate.Step where 2 | 3 | import Data.Map.Strict qualified as Map 4 | import Data.Set qualified as Set 5 | import Data.List ( mapAccumL ) 6 | 7 | 8 | import Evaluate.State ( State(..), Action(..) ) 9 | 10 | import Term ( Predicate(..), Struct(..), Term(..), Goal(..) ) 11 | 12 | 13 | step :: State -> Action State 14 | -- In these two equations we handle the situation 15 | -- when in the previous step we have successfully proved the whole goal 16 | -- that leaves us with an empty goal'stack. 17 | -- These two equations handle the situation when no backtracking can happen (empty backtracking'stack) 18 | -- or if some backtracking can happen (Redoing). 19 | -- It's not ideal as the idea that the Action transitions from Succeede to either Done or Redoing is only in our heads. 20 | -- It would be much better if it could be encoded in the design so that the type system and pattern matching 21 | -- exhaustivity checker would have our backs, but it is what it is. 22 | step state@State{ backtracking'stack = [] 23 | , goal'stack = [] } 24 | = Done 25 | 26 | step state@State{ backtracking'stack = record : backtracking'stack 27 | , goal'stack = [] } 28 | = Redoing state' 29 | where (new'goal'stack, pos, q'vars) = record 30 | state' = state{ goal'stack = new'goal'stack 31 | , position = pos 32 | , query'vars = q'vars 33 | , backtracking'stack } 34 | 35 | {- PROVE CALL -} 36 | step state@State{ base 37 | , backtracking'stack 38 | , goal'stack = gs@(Call (f@Struct{ name, args }) : goal'stack) 39 | , position 40 | , query'vars 41 | , counter } 42 | = case look'for f (drop position base) position of 43 | Nothing -> fail'and'backtrack state 44 | 45 | Just (Fact (Struct{ args = patterns }), the'position) -> 46 | let (counter', patterns') = rename'all patterns counter 47 | goals = map (uncurry Unify) (zip args patterns') 48 | new'goal'stack = goals ++ goal'stack 49 | 50 | backtracking'stack' = cause'backtracking f base (the'position + 1) gs query'vars backtracking'stack 51 | 52 | new'state = state{ backtracking'stack = backtracking'stack' 53 | , goal'stack = new'goal'stack 54 | , position = 0 -- the current goal will never ever be tried again (in this goal'stack anyway) 55 | , counter = counter' } 56 | 57 | in Searching new'state 58 | 59 | Just (Struct{ args = patterns } :- body, the'position) -> 60 | let (counter', patterns', body') = rename'both patterns body counter 61 | head'goals = map (uncurry Unify) (zip args patterns') 62 | new'goal'stack = head'goals ++ body' ++ goal'stack 63 | 64 | backtracking'stack' = cause'backtracking f base (the'position + 1) gs query'vars backtracking'stack 65 | 66 | new'state = state{ backtracking'stack = backtracking'stack' 67 | , goal'stack = new'goal'stack 68 | , position = 0 -- the current goal will never ever be tried again 69 | , counter = counter' } 70 | 71 | in Searching new'state 72 | 73 | where look'for :: Struct -> [Predicate] -> Int -> Maybe (Predicate, Int) 74 | look'for _ [] _ = Nothing 75 | -- a fact with the same name and arity 76 | look'for f@Struct{ name, args } (fact@(Fact (Struct{ name = name', args = args' })) : base) pos 77 | | name == name' && length args == length args' = Just (fact, pos) 78 | | otherwise = look'for f base (pos + 1) 79 | -- | Struct :- Term 80 | -- a rule with the same name and arity 81 | look'for f@Struct{ name, args } (rule@(Struct{ name = name', args = args' } :- body) : base) pos 82 | | name == name' && length args == length args' = Just (rule, pos) 83 | | otherwise = look'for f base (pos + 1) 84 | 85 | 86 | cause'backtracking :: Struct -> [Predicate] -> Int -> [Goal] -> Map.Map String Term -> [([Goal], Int, Map.Map String Term)] -> [([Goal], Int, Map.Map String Term)] 87 | cause'backtracking f base position goal'stack q'vars backtracking'stack 88 | = case look'for f (drop position base) position of 89 | Nothing -> backtracking'stack 90 | Just (_, future'position) -> 91 | let backtracking'record = (goal'stack, future'position, q'vars) 92 | in backtracking'record : backtracking'stack 93 | 94 | {- PROVE UNIFICATION -} 95 | step state@State{ base 96 | , backtracking'stack 97 | , goal'stack = Unify value'l value'r : goal'stack 98 | , position 99 | , query'vars 100 | , counter } 101 | = case unify (value'l, value'r) goal'stack query'vars of 102 | Nothing -> 103 | -- could not unify 104 | -- this means that this goal, fails 105 | fail'and'backtrack state 106 | Just (new'goal'stack, new'query'vars) -> 107 | -- they can be unified and the new'environment reflects that 108 | -- just return a new state with stack and env changed 109 | succeed state { goal'stack = new'goal'stack, query'vars = new'query'vars } 110 | 111 | 112 | succeed :: State -> Action State 113 | succeed state@State{ goal'stack = [] } 114 | = Succeeded state 115 | 116 | succeed state 117 | = Searching state 118 | 119 | 120 | -- The following function fails the current goal. 121 | -- It needs to replace the current goal'stack with a top of the backtracking one. 122 | -- That means re-setting the position and the environment. 123 | -- The counter stays the same (because it only increments). 124 | fail'and'backtrack :: State -> Action State 125 | fail'and'backtrack state@State{ backtracking'stack = [] } 126 | = Failed 127 | 128 | fail'and'backtrack state@State{ backtracking'stack = backtrack'record : backtracking'stack } 129 | = step state{ backtracking'stack 130 | , goal'stack = new'goal'stack 131 | , position = pos 132 | , query'vars = q'vars } 133 | where (new'goal'stack, pos, q'vars) = backtrack'record 134 | 135 | 136 | rename'all :: [Term] -> Int -> (Int, [Term]) 137 | rename'all patterns counter = (counter', patterns') 138 | where 139 | ((counter', mapping), patterns') = mapAccumL rename'val (counter, Map.empty) patterns 140 | 141 | 142 | rename'val :: (Int, Map.Map String String) -> Term -> ((Int, Map.Map String String), Term) 143 | rename'val (cntr, mapping) (Var name) 144 | = if Map.member name mapping 145 | then ((cntr, mapping), Var (mapping Map.! name)) 146 | else let new'name = "_" ++ show cntr 147 | new'cntr = cntr + 1 148 | new'mapping = Map.insert name new'name mapping 149 | in ((new'cntr, new'mapping), Var new'name) 150 | 151 | rename'val state (Compound (Struct{ name, args })) 152 | = let (state', args') = mapAccumL rename'val state args 153 | in (state', Compound (Struct{ name = name, args = args' })) 154 | 155 | rename'val acc val 156 | = (acc, val) 157 | 158 | 159 | rename'both :: [Term] -> [Goal] -> Int -> (Int, [Term], [Goal]) 160 | rename'both patterns goals counter = (counter', patterns', goals') 161 | where 162 | (state, patterns') = mapAccumL rename'val (counter, Map.empty) patterns 163 | 164 | (state', goals') = mapAccumL rename'goal state goals 165 | 166 | (counter', _) = state' 167 | 168 | 169 | rename'goal :: (Int, Map.Map String String) -> Goal -> ((Int, Map.Map String String), Goal) 170 | rename'goal state (Call (Struct{ name, args })) 171 | = let (state', args') = mapAccumL rename'val state args 172 | in (state', Call (Struct{ name, args = args' })) 173 | rename'goal state (Unify val'l val'r) 174 | = let (state', [val'l', val'r']) = mapAccumL rename'val state [val'l, val'r] 175 | in (state', Unify val'l' val'r') 176 | 177 | 178 | unify :: (Term, Term) -> [Goal] -> Map.Map String Term -> Maybe ([Goal], Map.Map String Term) 179 | {- DELETE (basically) -} 180 | unify (Wildcard, _) goals query'vars = Just (goals, query'vars) 181 | unify (_, Wildcard) goals query'vars = Just (goals, query'vars) 182 | 183 | {- DELETE -} 184 | unify (Atom a, Atom b) goals query'vars 185 | | a == b = Just (goals, query'vars) 186 | | otherwise = Nothing 187 | 188 | {- DECOMPOSE + CONFLICT -} 189 | unify ( Compound Struct{ name = name'a, args = args'a } 190 | , Compound Struct{ name = name'b, args = args'b }) 191 | goals query'vars 192 | | name'a /= name'b || length args'a /= length args'b = Nothing -- CONFLICT 193 | | otherwise = Just (arg'goals ++ goals, query'vars) -- DECOMPOSE 194 | where 195 | arg'goals :: [Goal] 196 | arg'goals = zipWith Unify args'a args'b 197 | 198 | {- ELIMINATE + OCCURS -} 199 | unify (Var a, value) goals query'vars 200 | | (Var a) == value = Just (goals, query'vars) -- DELETE (both are variables) 201 | | occurs a value = Nothing -- OCCURS CHECK (the one on the right is not a variable so I can do the check!) 202 | | otherwise = Just (substituted'goals, substituted'query'vars) 203 | where 204 | substituted'goals = map (subst'goal (a, value)) goals 205 | substituted'query'vars = Map.map (subst'val (a, value)) query'vars 206 | 207 | subst'goal :: (String, Term) -> Goal -> Goal 208 | subst'goal substitution (Call fun) = Call substituted'fun 209 | where substituted'fun = subst'functor substitution fun 210 | subst'goal substitution (Unify val'a val'b) = Unify substituted'val'a substituted'val'b 211 | where substituted'val'a = subst'val substitution val'a 212 | substituted'val'b = subst'val substitution val'b 213 | 214 | subst'val :: (String, Term) -> Term -> Term 215 | subst'val (from, to) (Var name) 216 | | name == from = to 217 | | otherwise = Var name 218 | subst'val _ (Atom name) = Atom name 219 | subst'val substitution (Compound fun) = Compound (subst'functor substitution fun) 220 | subst'val _ Wildcard = Wildcard 221 | 222 | subst'functor :: (String, Term) -> Struct -> Struct 223 | subst'functor substitution Struct{ name, args } = Struct{ name, args = substituted'args } 224 | where substituted'args = map (subst'val substitution) args 225 | 226 | {- SWAP (because of the above equation, we assume the `value` not being a variable) -} 227 | unify (value, Var b) goals query'vars = unify (Var b, value) goals query'vars 228 | 229 | unify _ _ _ = Nothing -- CONFLICT (for atoms and structs) 230 | 231 | 232 | occurs :: String -> Term -> Bool 233 | occurs var'name (Var name) = var'name == name 234 | occurs var'name (Atom _) = False 235 | occurs var'name (Compound Struct{ args }) = any (occurs var'name) args 236 | occurs var'name Wildcard = False 237 | -------------------------------------------------------------------------------- /src/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | module Lexer ( lexer, read'token, eval'parser, Lexer(..), Lexer'State(..), AlexInput(..) ) where 3 | 4 | import Control.Monad.State ( MonadState(get, put), gets, StateT( runStateT ), State ) 5 | import Control.Monad.Except ( Except, runExcept, throwError ) 6 | 7 | import Data.Word ( Word8 ) 8 | import Data.Char ( ord ) 9 | import Data.List ( uncons ) 10 | 11 | import Token ( Token ) 12 | import Token qualified as Token 13 | 14 | } 15 | 16 | 17 | $upper = [A-Z] 18 | 19 | $lower = [a-z] 20 | 21 | @variableident = $upper+ 22 | 23 | @atomident = $lower+ 24 | 25 | $space = [\ \t\f\v\n] 26 | 27 | 28 | minilog :- 29 | 30 | $space+ ; 31 | 32 | "%".*\n ; 33 | 34 | "," { \_ -> token Token.Comma } 35 | 36 | "." { \_ -> token Token.Period } 37 | 38 | ":-" { \_ -> token Token.If } 39 | 40 | "=" { \_ -> token Token.Equal } 41 | 42 | "(" { \_ -> token Token.Paren'Open } 43 | 44 | ")" { \_ -> token Token.Paren'Close } 45 | 46 | "_" { \_ -> token Token.Underscore } 47 | 48 | @variableident { emit Token.Var } 49 | 50 | @atomident { emit Token.Atom } 51 | 52 | 53 | { 54 | 55 | lexer :: (Token -> Lexer a) -> Lexer a 56 | lexer cont = read'token >>= cont 57 | 58 | 59 | read'token :: Lexer Token 60 | read'token = do 61 | s <- get 62 | case alexScan (lexer'input s) 0 of 63 | AlexEOF -> return Token.EOF 64 | 65 | AlexError inp' -> 66 | throwError ("Lexical error on line " ++ (show $! ai'line'no inp') ++ " and column " ++ (show $! ai'col'no inp'), ai'col'no inp') 67 | 68 | AlexSkip inp' _ -> do 69 | put s{ lexer'input = inp' } 70 | read'token 71 | 72 | AlexToken inp' n act -> do 73 | let (Input{ ai'input = buf }) = lexer'input s 74 | put s{ lexer'input = inp' } 75 | act (take n buf) 76 | 77 | 78 | -- The functions that must be provided to Alex's basic interface 79 | alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) 80 | alexGetByte input@Input{ ai'input } 81 | = advance <$> uncons ai'input 82 | where 83 | advance :: (Char, String) -> (Word8, AlexInput) 84 | advance ('\n', rest) 85 | = ( fromIntegral (ord '\n') 86 | , Input { ai'line'no = ai'line'no input + 1 87 | , ai'col'no = 1 88 | , ai'last'char = '\n' 89 | , ai'input = rest } ) 90 | advance (c, rest) 91 | = ( fromIntegral (ord c) 92 | , Input { ai'line'no = ai'line'no input 93 | , ai'col'no = ai'col'no input + 1 94 | , ai'last'char = c 95 | , ai'input = rest } ) 96 | 97 | 98 | token :: Token -> Lexer Token 99 | token t = return t 100 | 101 | 102 | emit :: (String -> Token) -> String -> Lexer Token 103 | emit mk't str = return (mk't str) 104 | 105 | 106 | get'line'no :: Lexer Int 107 | get'line'no = gets (ai'line'no . lexer'input) 108 | 109 | 110 | get'col'no :: Lexer Int 111 | get'col'no = gets (ai'col'no . lexer'input) 112 | 113 | 114 | eval'parser :: Lexer a -> String -> Either (String, Int) (a, Lexer'State) 115 | eval'parser parser source = runExcept $! runStateT parser (initial'state source) 116 | 117 | 118 | type Lexer a = StateT Lexer'State (Except (String, Int)) a 119 | 120 | 121 | data AlexInput = Input 122 | { ai'line'no :: !Int 123 | , ai'col'no :: !Int 124 | , ai'last'char :: !Char 125 | , ai'input :: String } 126 | deriving (Eq, Show) 127 | 128 | 129 | data Lexer'State = Lexer'State 130 | { lexer'input :: !AlexInput } 131 | deriving (Eq, Show) 132 | 133 | 134 | initial'state :: String -> Lexer'State 135 | initial'state s = Lexer'State 136 | { lexer'input = Input 137 | { ai'line'no = 1 138 | , ai'col'no = 1 139 | , ai'last'char = '\n' 140 | , ai'input = s } } 141 | 142 | } 143 | -------------------------------------------------------------------------------- /src/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Parser ( parse'base, parse'query ) where 5 | 6 | import Control.Monad.Except ( throwError ) 7 | import Control.Monad.State 8 | import Data.Either.Extra ( mapRight ) 9 | 10 | import Token ( Token ) 11 | import Token qualified 12 | 13 | import Lexer 14 | 15 | import Term 16 | 17 | } 18 | 19 | 20 | %name parseBase Base 21 | %name parseBody Body 22 | 23 | %tokentype { Token } 24 | %monad { Lexer } 25 | %lexer { lexer } { Token.EOF } 26 | 27 | %errorhandlertype explist 28 | %error { parseError } 29 | 30 | %token 31 | VAR { Token.Var $$ } 32 | 33 | ATOM { Token.Atom $$ } 34 | 35 | ',' { Token.Comma } 36 | '.' { Token.Period } 37 | ':-' { Token.If } 38 | '=' { Token.Equal } 39 | '(' { Token.Paren'Open } 40 | ')' { Token.Paren'Close } 41 | '_' { Token.Underscore } 42 | 43 | %% 44 | 45 | 46 | Base :: { [Predicate] } 47 | : Predicates { $1 } 48 | 49 | 50 | Predicates :: { [Predicate] } 51 | : Predicate { [ $1 ] } 52 | | Predicate Predicates { $1 : $2 } 53 | 54 | 55 | Predicate :: { Predicate } 56 | : Struct '.' { Fact $1 } 57 | | Struct ':-' Body { $1 :- $3 } 58 | 59 | 60 | Body :: { [Goal] } 61 | : Goals '.' { $1 } 62 | 63 | 64 | Struct :: { Struct } 65 | : ATOM '(' Terms ')' { Struct{ name = $1, args = $3 } } 66 | 67 | 68 | Terms :: { [Term] } 69 | : Term { [ $1 ] } 70 | | Term ',' Terms { $1 : $3 } 71 | 72 | Term :: { Term } 73 | : VAR { Var $1 } 74 | | ATOM { Atom $1 } 75 | | Struct { Compound $1 } 76 | | '_' { Wildcard } 77 | 78 | 79 | Goals :: { [Goal] } 80 | : Goal { [ $1 ] } 81 | | Goal ',' Goals { $1 : $3 } 82 | 83 | 84 | Goal :: { Goal } 85 | : Struct { Call $1 } 86 | | Term '=' Term { Unify $1 $3 } 87 | 88 | { 89 | 90 | parse'base :: String -> Either (String, Int) [Predicate] 91 | parse'base source = mapRight fst $! eval'parser parseBase source 92 | 93 | 94 | parse'query :: String -> Either (String, Int) [Goal] 95 | parse'query source = mapRight fst $! eval'parser parseBody source 96 | 97 | 98 | parseError _ = do 99 | col'no <- gets (ai'col'no . lexer'input) 100 | l'no <- gets (ai'line'no . lexer'input) 101 | last'char <- gets (ai'last'char . lexer'input) 102 | state <- get 103 | throwError ("Parse error near character `" ++ [last'char] ++ "' on line " ++ show l'no ++ ", column " ++ show col'no ++ ".", col'no) 104 | 105 | } -------------------------------------------------------------------------------- /src/Term.hs: -------------------------------------------------------------------------------- 1 | module Term where 2 | 3 | import Data.List ( intercalate ) 4 | 5 | 6 | data Goal = Call !Struct 7 | | Unify !Term !Term 8 | deriving (Eq) 9 | 10 | 11 | data Predicate = Fact !Struct 12 | | !Struct :- ![Goal] 13 | deriving (Eq) 14 | 15 | 16 | data Struct = Struct{ name :: !String, args :: ![Term] } 17 | deriving (Eq) 18 | 19 | 20 | data Term = Var !String 21 | | Atom !String 22 | | Compound !Struct 23 | | Wildcard 24 | deriving (Eq) 25 | 26 | 27 | instance Show Goal where 28 | show (Call struct) = show struct 29 | show (Unify val'l val'r) = show val'l ++ " = " ++ show val'r 30 | 31 | 32 | instance Show Predicate where 33 | show (Fact struct) = show struct ++ "." 34 | show (head :- body) = show head ++ " :- " ++ intercalate " , " (map show body) ++ "." 35 | 36 | 37 | instance Show Struct where 38 | show Struct{ name, args } = name ++ "(" ++ intercalate ", " (map show args) ++ ")" 39 | 40 | 41 | instance Show Term where 42 | show (Var name) = name 43 | show (Atom name) = name 44 | show (Compound struct) = show struct 45 | show Wildcard = "_" 46 | -------------------------------------------------------------------------------- /src/Token.hs: -------------------------------------------------------------------------------- 1 | module Token where 2 | 3 | 4 | data Token = Atom String 5 | | Var String 6 | | If 7 | | Comma 8 | | Period 9 | | Paren'Open 10 | | Paren'Close 11 | | Underscore 12 | | Equal 13 | | EOF 14 | deriving (Eq, Show) 15 | --------------------------------------------------------------------------------