diff --git a/.gitignore b/.gitignore index 389e9ac..2e76dfe 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,12 @@ *~ .DS_Store *.beam +ebin +.idea +*.iml +erlog_scan.erl +*.dump +rel/erlog +.rebar +.eunit +deps diff --git a/src/ChangeLog b/ChangeLog similarity index 100% rename from src/ChangeLog rename to ChangeLog diff --git a/Makefile b/Makefile index 138472f..e3a67fb 100644 --- a/Makefile +++ b/Makefile @@ -37,6 +37,9 @@ compile: ## Compile using erlc erlc_compile: $(addprefix $(EBINDIR)/, $(EBINS)) +rel: compile + rebar generate + docs: clean: diff --git a/README b/README deleted file mode 100644 index 2d1d664..0000000 --- a/README +++ /dev/null @@ -1,3 +0,0 @@ -Erlog is a Prolog interpreter implemented in Erlang and integrated -with the Erlang runtime system. It is a subset of the Prolog standard. -An erlog shell is also included. diff --git a/README.md b/README.md new file mode 100644 index 0000000..191c968 --- /dev/null +++ b/README.md @@ -0,0 +1,156 @@ +Erlog is a Prolog interpreter implemented in Erlang and integrated +with the Erlang runtime system. It is a subset of the Prolog standard. +An erlog shell is also included. + +### Usage +Make erlog: + + make rel + +#### Command line prolog coding: +##### Local shell +To use local shell just run erlang emulator in directory with compiled beam files (`ebin`) and run local shell: + + make + cd ebin + erl + erlog_local_shell:start(). +##### Remote shell +You can use remote shell and connect to it via telnet. +Run release: + + ./rel/erlog/bin/erlog start +And connect to it via console: + + telnet 127.0.0.1 8080 +Port can be set up in `src/erlog.app.src`. + +#### Debugger +Debugger can be passed to erlog as a parameter {debugger, Fun}, where `Fun` is your fun of calling debugger: + + {ok, Core} = erlog:start_link([{debugger, fun(Status, Functor, Result) -> gen_server:call(Debugger, {Status, Functor, Result}) end}]), +Where __Status__ is a status of command - `ok|failed`, __Functor__ is current working functor, __Result__ is a result +prolog term - complex structure with all data. +As an example you can use `erlog_simple_debugger` with `erlog_local_shell`: + + {ok, Pid} = erlog_simple_debugger:start_link(). + erlog_local_shell:start(Pid). +More in [docs](https://github.com/comtihon/erlog/blob/master/doc/debugger.md "debugger"). + +#### Processing prolog code from erlang: +##### Starting +Spawn new logic core: + + {ok, Pid} = erlog:start_link(). +##### Executing +Process prolog terms, using your core: + + erlog:execute(Worker, Command). +Where: +`Command` is a command, ended with dot, +`Worker` is a pid of your prolog logic core. +##### Selecting +When erlog:execute returns `select` in result - you can select for some other result calling `erlog:select/2` instead of execute. + + erlog:select(Worker, ";"). +Full Example: + + (erlog@127.0.0.1)1> {ok, Pid} = erlog:start_link(). + {ok,<0.961.0>} + (erlog@127.0.0.1)2> erlog:execute(Pid, "assert(father('victor', 'andrey'))."). + true + (erlog@127.0.0.1)3> erlog:execute(Pid, "father('victor', 'andrey')."). + true + (erlog@127.0.0.1)4> erlog:execute(Pid, "father('victor', 'vasya')."). + false + (erlog@127.0.0.1)5> erlog:execute(Pid, "run(S)."). + {{true,[{'S',600}]}, select} + (erlog@127.0.0.1)6> erlog:select(Pid, ";"). + false + +#### Custom database server: +Erlog now supports using your own database, instead of using ets and dicts. Just implement `erlog_storage` callback interface +and pass your module name with your implementation to `erlog:start_link/1` as __database__ to configuration list. +Example: + + ConfList = [{database, mysql_storage_impl_module}], + erlog:start_link(ConfList). +You can pass your parameters to your database implementation: + + ConfList = [{database, dbModule}, {arguments, Params}], + erlog:start_link(ConfList). +Where `Params` is a list of your args, need to be passed to `dbModule:new/1` function. + +#### Consulting files +To consult files use brakes and filename with path `["/home/prolog_user/prolog_code/examples/family.pl"]`. +Erlog also supports calling `consult/1` and `reconsult/1` from prolog code: + + erlog:execute(Pid, "consult(\"/home/prolog_user/prolog_code/examples/family.pl\")."). +__Remember!__ For proper consulting files with default consulter, files should end with empty line! + +#### Custom file consulter: +File consulter is a module, used to operate with files. It's behaviour is described in `erlog_file_consulter`. It should +implement two functions: `lookup` and `load`. Lookup returns list of all prolog libraries from selected directory and load +reads selected file and parse it to prolog terms. +Default implementation use files and directories for libraries search and loading. If you implement your own file consulter, +f.e. if you use database filesystem or smth else - implement `erlog_file_consulter` behaviour in your module and pass its +name in erlog configuration as __f_consulter__: + + ConfList = [{f_consulter, my_hadoop_consulter}], + erlog:start_link(ConfList). + +#### Custom debugger handler: +If you wan't to use functions from debug library - you should define your own gen_event handler and pass it to erlog. +All debug events from such debug functions as `writeln/1` will be passed there. +See `erlog_simple_printer` as a default implementation of console printer as an example, or `erlog_remote_eh`, which is +intended to print debug to remote client. +To configure your gen_event module - just pass module and arguments as __event_h__ in configuration: + + ConfList = [{event_h, {my_event_handler, Args}}], + erlog:start_link(ConfList). + +#### Working with libraries: +Erlog supports two kinds of libraries: native (written in Erlang) and extended (written in Prolog). Native libraries can +be standard and external. +All predicates from standard libraries are loaded to memory when you start erlog core. +All prolog libraries from `lib/autoload` are also loaded to memory when you start erlog core. +##### Manual loading external libraries +But to use predicates from external functions - you should manually load them to memory with the help of `use/1` command: + + | ?- db_assert(test,foo(a,b)). + false + | ?- use(erlog_db). + true + | ?- db_assert(test,foo(a,b)). + true +This example demonstrates the loading of external database library. +First call is false, because there is no such function loaded to memory. +Second - library is loaded. +Third - function run successfully. +__Important!__ If you are working with erlog from poolboy or dynamic creating erlog gen_servers through supervisor, +remember, that two execution requests can be processed on different erlog instance. + + use(some_lib). %returns true + some_lib_fun(some_val). %returns false +In this example system erlog gen server is created one per one separate command (F.e. http request). Firstly - library +`some_lib` is loaded. Than erlog server with loaded library is destroyed (as request is complete) and for another request +`some_lib_fun(some_val)` another erlog server is created, but, without loaded library. +##### Automatic libraries loading +For convenient libraries usage you can load all libraries you need when creating a core. It will let you not to call `use/1` +everywhere in your code. Just add param `{libraries, [my_first_lib, my second_lib]}` in your params when starting a core: + + ConfList = [{libraries, [Lib1, Lib2]}], + erlog:start_link(ConfList). +All libraries from array will be loaded. +More in [docs](https://github.com/comtihon/erlog/blob/master/doc/libraries.md "libraries"). +##### Loading Prolog libraries +When configuring erlog you should set default library directory as __libs_dir__: + + ConfList = [{libs_dir, "/usr/share/prolog/lib/"}], + erlog:start_link(ConfList). +If you don't set this - erlog will use `../lib` directory, assuming it was run from `ebin`. +For manual loading prolog library - also try `use`, but instead of __atom__ name call it with __string__ library name: + + use(erlog_cache). %use extended native library + use("proc/cuda/driver.pl"). %use prolog library, from /usr/share/prolog/lib/proc/cuda/ +__Important!__ To avoid `erlog_parse,{operator_expected,'.'}` error - sure, that last character in your prolog file is `\n`. \ No newline at end of file diff --git a/doc/debugger.md b/doc/debugger.md new file mode 100644 index 0000000..0ee07a0 --- /dev/null +++ b/doc/debugger.md @@ -0,0 +1,107 @@ +### Using debugger +Debugger is started in `listing` mode by default. Listing just log every goal call and memory after previous call. For +more efficient usage - stop points can be added. + +#### Stopping with counter +To stop commands execution after N executed commands - configure debugger with `next N`, where N is a positive integer. +When N goals is skipped - you will be asked again. You can configure the action by hitting C, or skipping next N goals +by pressing `enter`. +Example: + + 1> {ok, Pid} = erlog_simple_debugger:start_link(). + {ok,<0.34.0>} + 2> erlog_simple_debugger:configure(Pid). + Select action + | ?- next 5 + ok + 3> erlog_local_shell:start(Pid). + Erlog Shell V6.1 with debugger (abort with ^G)ert(foo(a,b)), foo(a,b), writeln("world"). + Skip {call,{',',{assert,{foo,a,c}}, + | ?- assert(foo(a,c)), writeln("hello"), retract(foo(a,c)), ass + {',',{writeln,"hello"}, + {',',{retract,{foo,a,c}}, + {',',{assert,{foo,a,b}}, + {',',{foo,a,b},{writeln,"world"}}}}}}} + Skip {assert,{foo,a,c}} + Skip {writeln,"hello"} + Skip {retract,{foo,a,c}} + Erlog debugger stopped execution on command {assert,{foo,a,b}} with memory: []. + [C_]:C + Select action + +#### Stopping with goal +To stop commands execution after special command (breakpoint) - configure debugger with `stop G`, where G is a goal. Goal +can be set direct - with params, f.e. `foo(a,b)` - it will react only on this goal, or indirect - by arity `foo/2` - it +will react on every foo with arity 2. When such goal will be executed - debugger will stop code execution and ask you for +next configuration. If you want to skip all code up to an end - just use `listing`. +Example: + + 1> {ok, Pid} = erlog_simple_debugger:start_link(). + {ok,<0.34.0>} + 2> erlog_simple_debugger:configure(Pid). + Select action + | ?- stop assert(foo(a,b)) + ok + 3> erlog_local_shell:start(Pid). + Erlog Shell V6.1 with debugger (abort with ^G) + | ?- assert(foo(a,c)), writeln("hello"), retract(foo(a,c)), assert(foo(a,b)), foo(a,b), writeln("world"). + Skip {call,{',',{assert,{foo,a,c}}, + {',',{writeln,"hello"}, + {',',{retract,{foo,a,c}}, + {',',{assert,{foo,a,b}}, + {',',{foo,a,b},{writeln,"world"}}}}}}} + Skip {assert,{foo,a,c}} + Skip {writeln,"hello"} + Skip {retract,{foo,a,c}} + Erlog debugger stopped execution on command {assert,{foo,a,b}} with memory: []. + Select action + +#### Spying for goals +To debug only for selected goal - use `spy G`, where G is a goal. Goal can be set by arity or direct, same as in stop +section. When goal matches - debugger will print execution, otherwise it will be silent. + + 1> {ok, Pid} = erlog_simple_debugger:start_link(). + {ok,<0.34.0>} + 2> erlog_simple_debugger:configure(Pid). + Select action + | ?- spy foo/2 + ok + 3> erlog_local_shell:start(Pid). + Erlog Shell V6.1 with debugger (abort with ^G) + | ?- assert(foo(a,b)), assert(foo(a,c)), foo(a,b), assert(foo(a,c)), foo(a,c), assert(foo(a,d)),foo(a,d), assert(foo(a,b)). + Execute {foo,a,b}, memory: [] + true + +#### Stopping with breakpoint +To stop execution somewhere in your code before specific functor - place breakpoint on this line. To place breakpoint in +code use `'??'` special functor. +Example code with one breakpoint: + + test:- + writeln("before breakpoint"), + '??'(writeln("stop me")), + writeln("after breakpoint"). +Output: + + 1> {ok, Pid} = erlog_simple_debugger:start_link(). + {ok,<0.34.0>} + 2> erlog_local_shell:start(Pid). + Erlog Shell V6.1 with debugger (abort with ^G) + | ?- consult('/home/prolog/test_debug.pl'). + Execute {call,{consult,'/home/prolog/test_debug.pl'}}, memory: [] + Execute {consult,'/home/prolog/test_debug.pl'}, memory: [] + true + | ?- test. + Execute {call,test}, memory: [] + Execute test, memory: [] + Execute {writeln,"before breakpoint"}, memory: [] + erlog_simple_printer: "before breakpoint" + Execute {'??',{writeln,"stop me"}, memory: [] + Erlog debugger stopped execution on command {writeln,"stop me"} with memory: []. + Select action + | ?- listing + erlog_simple_printer: "stop me" + Execute {writeln,"after breakpoint"}, memory: [] + erlog_simple_printer: "after breakpoint" + true + \ No newline at end of file diff --git a/doc/erlog.txt b/doc/erlog.txt deleted file mode 100644 index 7876f09..0000000 --- a/doc/erlog.txt +++ /dev/null @@ -1,93 +0,0 @@ -MODULE - - erlog - -MODULE SUMMARY - - Interpreter for sub-set of Prolog - -DESCRIPTION - - Erlog is a Prolog interpreter implemented in Erlang and - integrated with the Erlang runtime system. - -EXPORTS - -erlog:new() -> Erlog() - - Start a new Erlog interpreter. The intrepreter is a function - which can be called with the following valid arguments: - - Erlog({prove,Goal}) -> {ProveRet,Erlog()}. - Erlog(next_solution) -> {ProveRet,Erlog()}. - - where ProveRet = {succeed,VarBindings} | fail | Error. - - Goal can also be a list of goals here to simplify writing - conjunctions. - - Erlog({consult,FileName} -> {ok,Erlog()} | {Error,Erlog()}. - Erlog({reconsult,FileName} -> {ok,Erlog()} | {Error,Erlog()}. - - Erlog(get_db) -> {{ok,Database},Erlog()}. - Erlog({set_db,Database}) -> {ok,Erlog()}. - - Get/set the database used by the interpreter to Database. - These functions can be used to save and quickly restore the - database to a predefined state. - - Erlog(halt) -> ok. - This ends the interpreter. - -erlog:start() -> Eint. -erlog:start_link() -> Eint. -erlog:prove(Eint, Goal) -> {succeed,VarBindings} | fail | Error. -erlog:next_solution(Eint) -> {succeed,VarBindings} | fail | Error. -erlog:consult(Eint, FileName) -> ok | Error. -erlog:reconsult(Eint, FileName) -> ok | Error. -erlog:get_db(Eint) -> {ok,Database}. -erlog:set_db(Eint, Database) -> ok. -erlog:halt(Eint) -> ok. - - These functions run the Erlog interpreter as a separate - process, the interface functions correspond to the valid - arguments to the Erlog interpeter function above. - -erlog:is_legal_term(Term) -> bool(). - - Test if Term is a well-formed (legal) Erlog structure. - -erlog:vars_in(Term) -> [{VarName,Variable}]. - - Returns a list of {VariableName,Variable} pairs. - -erlog_parse:term([Token]) -> {ok,Term} | {error,ErrorDescriptor}. -erlog_parse:term([Token], LineNo) -> {ok,Term} | {error,ErrorDescriptor}. - - Parse a list of Erlang tokens as a Prolog term. The line - number (default 1) is used when returning errors. - ErrorDescriptor has the format: - - {LineNo,ModuleName,Error} - -erlog_scan:string(String) -> {ok,[Token],Line} | {error,Error,LineNo}. -erlog_scan:string(String, Line) -> {ok,[Token],Line} | {error,Error,Line}. - - Scan String and return a list of tokens. - -erlog_scan:token(Continuation, Chars, Line) -> - {more,Continuation} | {done,ReturnVal,RestChars}. - - Re-entrant scanner to scan one token. Compatible with io system. - -erlog_scan:tokens(Continuation, Chars, Line) -> - {more,Continuation} | {done,ReturnVal,RestChars}. - - Re-entrant scanner to scan tokens upto an end token. - Compatible with io system. - -AUTHOR - - Robert Virding - robert.virding@telia.com - (with thanks to Richard O'Keefe for explaining some finer - points of the Prolog standard) diff --git a/doc/erlog_shell.txt b/doc/erlog_shell.txt deleted file mode 100644 index 3d5d353..0000000 --- a/doc/erlog_shell.txt +++ /dev/null @@ -1,34 +0,0 @@ -MODULE - - erlog_shell - -MODULE SUMMARY - - Erlog shell. - -DESCRIPTION - - Erlog is a Prolog interpreter implemented in Erlang and - integrated with the Erlang runtime system. This is a simple - prolog like shell to run Erlog. - -EXPORTS - -erlog_shell:start() -> ShellPid. - - Start a simple Erlog shell in a new process. Goals can be - entered at the "?-" prompt. When the goal succeeds the - variables and their values will be printed and the user - prompted. If a line containing a ";" is entered the system - will attempt to find the next solution, otherwise the system - will return to the "?-" prompt. - -erlog_shell:server() -> ok. - - Start a simple Erlog shell in the current process. - -AUTHOR - - Robert Virding - robert.virding@telia.com - (with thanks to Richard O'Keefe for explaining some finer - points of the Prolog standard) diff --git a/doc/libraries.md b/doc/libraries.md new file mode 100644 index 0000000..6daede4 --- /dev/null +++ b/doc/libraries.md @@ -0,0 +1,85 @@ +### Core libraries +They are standard `built_in` libraries: + + * `erlog_bips` - core built-in functions. + * `erlog_core` - basic language functions. + * `erlog_dcg` - DCG conversion and procedures. + * `erlog_lists` - standard lists support. + * `erlog_time` - date and time support library. + +All built-in libraries have same behaviour `erlog_stdlib`. They have `load/1` function and `prove_goal/1` function. +In `load` function - all initialisation of library is made. Starting all needed services, parsing prolog functors, +loading predicates to memory and what not. +When `prove_goal` is called - `#param{}` record with working data is passed to it. Function for goal execution is +searching through pattern matching. +Core libraries are loaded into memory when erlog gen_server starts. + +### External libraries +They are external, user-defined libraries. They should also act as `erlog_exlib` behaviour, with `load/1` function. +`load` function made initialisation of library - as core library. Instead of `prove_goal` function - library functions +are defined in `*.hrl` files as compiled: + + {{Name, Arity}, Module, Function} +`Name` - is name of function in prolog, +`Arity` - is the arity of prolog function, +`Module` - is the erlang module, where processing function is defined, +`Function` - is erlang processing function. +External libraries are load into memory on demand, by calling `use(LibName)` function, where LibName is the name of the +erlang module with exlib behaviour. + +### Library autoload +For convenient libraries usage you can load all libraries you need when creating a core. It will let you not to call `use/1` +everywhere in your code. Just add param `{libraries, [my_first_lib, my second_lib]}` in your params when starting a core: + + ConfList = [{libraries, [my_first_lib, my second_lib]}], + erlog:start_link(ConfList). +All libraries from array will be loaded. +You can load native libraries - just pass name of your module where library is implemented to ConfList as an atom. Or you +can load library, written in prolog. In that case you should pass full path to library as a string: + + ConfList = [{libraries, [my_first_lib, my second_lib, "/home/user/testlib.pl"]}], + erlog:start_link(ConfList). + +### Writing your own libraries +You can write your own external libraries. For doing so - just setup behaviour `erlog_exlib`. It has one callback function +`load(Db)` for initialisation library. Then you should define your execution functions. See __External libraries__ for +instructions of library execution functions format. +Example: +_File `erlog_uid.hrl`_ + + -define(ERLOG_UID, + [ + {{id, 1}, ?MODULE, id_1} + ]). +_File `erlog_uid.erl`_ + + -behaviour(erlog_exlib). + -include("ep_uuid.hrl"). + -include("erlog_core.hrl"). + + -export([load/1, id_1/1]). + + load(Db) -> + lists:foreach(fun(Proc) -> erlog_memory:load_library_space(Db, Proc) end, ?ERLOG_UID). + + id_1(Params = #param{goal = {id, Res}, next_goal = Next, bindings = Bs0}) -> + Bs = ec_support:add_binding(Res, binary_to_list(uuid:generate()), Bs0), + ec_core:prove_body(Params#param{goal = Next, bindings = Bs}). + +### Prolog libraries +You can also write prolog libraries, which you can load manually of automatically. All this libraries will be loaded to +library space. For automatic loading libraries - move them to `lib/autoload` directory, or use library autoload standard method. +Note, that if you create a functor in prolog library and load this library - you won't create same functor in userspace with +the help of `assert`. Also - if you have same functors in different libraries - they will be rewritten by last loaded. + +#### When prefer autoloading? +You may noticed, that `use/1` and `consult/1` share same functionality. The only difference is that `consult` loads predicates +to __userspace__, while `use` loads predicates to __library space__ (Extended). When is it optional to select each? +If you work locally, without your own storage implementation - it doesnt' matter, as default erlog storage model for userspace is +same as for library space - dict. But when you have your own memory implementation - you should understand: + +* library space is dict, stored in local memory. It can be faster, than your remote database. +* when your system has many users, who shares some code (library) - consulting this library leads to copying it to user's +tables/collections/namespaces, while using library will make copy only in memory of user's thread. +* if you store huge number of facts into library - dict implementation of library space can show worse performance, than +your database. diff --git a/doc/memory.md b/doc/memory.md new file mode 100644 index 0000000..fc43113 --- /dev/null +++ b/doc/memory.md @@ -0,0 +1,36 @@ +### Erlog memory +#### Memory structure +All prolog predicates, that operate with memory - call `erlog_memory` gen_server for data. But `erlog_memory` does not +operate with data itself. It calls memory implementations, which behavior is described in `erlog_storage`. +Erlog memory is divided into three layers - __core__, __extended__ and __userspace__. +__Core__ memory contains all core library predicates. They are loaded there when erlog starts. It is implemented in dict, +which is stored in `erlog_memory` state. +__Extended__ memory contains all extended library predicates. They are loaded there on demand, using `use` keyword or +library autoload (see [docs](https://github.com/comtihon/erlog/blob/master/doc/libraries.md "libraries")) They are also +implemented in dict and stored in `erlog_memory` state. +__Userspace__ memory contains all facts and predicates - user loads himself. Its behavior is described in `erlog_storage`. +Module, which implements this behavior is stored in `erlog_memory`. By default `erlog_dict` is used, but you can select +`erlog_ets` or use your own. +`Erlog_memory` saves module, which implements memory, and its state. State is returned in `new` function and in functions, +which can probably modify it. See `erlog_storage` specification for details. State is passed to storage implementation on +every call. + +#### Using cursors +When prolog code is working - it often comes to a situation - where clauses for fact are found. Sometimes clauses number is +very big and multilayer. That is for cursors are used. When you use `erlog_storage` implementation with database - you can +fetch first clause from database and return cursor with result as `{cursor, Cursor, result, Result}`. Cursor will be saved +is erlog gen_server state and will fetch next clause from database if needed. If clause succeeded - cursor will be closed. +__Note__: prefer using cursors to fetching all clauses. + +#### Writing your own implementation +To write your own memory implementation, based on your favourite database, or cache, or something else - implement +`erlog_storage` behavior and pass your module name in arguments, when you start erlog (as mentioned in Readme). +`new/1` is called automatically - when erlog starts. New should be used for initialisation of the database. New takes +list as param which was sent in erlog arguments for database module. +`close/2` is called automatically - when erlog deside to close the cursor, database state can be updated there. +`next/2` is called automatically to fetch next clause value from database, database state can be updated there. Also, you +can update your cursor, if you hame some complex logic. +`get_procedure/2` is called automatically - when erlog is looking for a predicate to execute. First it search stdlib, then +extended lib and then userspace. It is main erlog predicate. Note, that it is called on every execution and can be the main +reason of loading the database. +Other functions are called manually, when different prolog predicates, depending on them, are called. \ No newline at end of file diff --git a/doc/user_guide.txt b/doc/user_guide.txt deleted file mode 100644 index a63ebf5..0000000 --- a/doc/user_guide.txt +++ /dev/null @@ -1,239 +0,0 @@ - Erlog - ===== - -DESCRIPTION - -Erlog is a Prolog interpreter implemented in Erlang and integrated -with the Erlang runtime system. It follows the Prolog standard and the -following subset of the built-ins have been implemented: - -Logic and control -call/1, ','/2, '!'/0, ';'/2, fail/0, '->'/2 (if-then), -( -> ; )(if-then-else), '\\+'/1, once/1, repeat/0, true/0 - -Term creation and decomposition -arg/3, copy_term/2, functor/3, '=..'/2 - -Clause creation and destruction -abolish/1, assert/1, asserta/1, assertz/1, retract/1, retractall/1. - -Clause retrieval and information -clause/2, current_predicate/1, predicate_property/2 - -Term unification and comparison -'@>'/2, '@>='/2, '=='/2, '\\=='/2, '@>'/2, '@=<'/2, '='/2, '\\='/2 - -Arithmetic evaluation and comparison -'>'/2, '>='/2, '=:='/2, '=\\='/2, '<'/2, '=<'/2, is/2 - -Type testing -atom/1, atomic/1, compound/1, integer/1, float/1, number/1, -nonvar/1, var/1 - -Atom processing -atom_chars/2, atom_length/2 - -Erlang interface -ecall/2 - -Useful but non-standard -expand_term/2, phrase/2, phrase/3 - -Common lists library -append/3, insert/3, delete/3, member/2, memberchk/2, reverse/2, -perm/2, sort/2 - -The following arithmetic operators are implemented: - -+/1, -/1, +/2, -/2, */2, //2, **/2, ///2, mod/2, abs/1, -float/1, truncate/1 - -Prolog terms in Erlog have a very direct representation in Erlang: - -Prolog Erlang ------- ------ -Structures Tuples where the first element - is the functor name (an atom) -Lists Lists -Variables Tuple {VariableName} where VariableName - is an atom -Atomic Atomic - -Note there is no problem with this representation of variables as -structures without arguments, a(), are illegal in Prolog. For example -the Prolog term: - -Goal = insert([1,2,3], atom, Es), call(Goal) - -is represented in Erlang by: - -{',',{'=',{'Goal'},{insert,[1,2,3],atom,{'Es'}}},{call,{'Goal'}}} - -The clauses of the standard append/3 defined by - -append([], L, L). -append([H|T], L, [H|T1]) :- - append(T, L, T1). - -are represented in Erlang by the terms: - -{append,[],{'L'},{'L'}}. -{':-',{append,[{'H'}|{'T'}],{'L'},[{'H'}|{'T1'}]}, - {append,{'T'},{'L'},{'T1'}}}. - -Limited checking is done at run-time, basically only of input terms. -Currently this is done for the top level when clauses are added to the -database and a goal is entered. - -ERLANG INTERFACE - -The interface to Erlang is through the ecall/2 predicate, which -provides a back-trackable interface to Erlang. It has the form: - -ecall(ErlangFunctionCall, ReturnValue) - -It calls the Erlang function and unifies the result with ReturnValue. -For example - -ecall(mymod:onefunc(A1, A2), Ret) -ecall(mymod:otherfunc, Ret) - -where the second form calls a function of no arguments -(funcname() is illegal syntax in Prolog). - -The Erlang function must return: - -{succeed,Value,Continuation} - - The function has succeeded and returns Value which is unified - with the output argument of ecall/2. Continuation will be - called on backtracking to generate the next value. - -{succeed_last,Value} - - This is the last time the function will succeed so no - continuation is returned. It is an optimisation of returning a - continuation which will fail the next time. - -fail - - The function cannot generate more solutions and fails. - -The first example is a simple function which calls an Erlang function -and returns the value: - -efunc(Fcall) -> - %% This is what the operators will generate. - Val = case Fcall of - {':',M,F} when is_atom(M), is_atom(F) -> M:F(); - {':',M,{F,A}} when is_atom(M), is_atom(F) -> M:F(A); - {':',M,T} when is_atom(M), is_tuple(T), size(T) >= 2, - is_atom(element(1, T)) -> - apply(M,element(1, T),tl(tuple_to_list(T))) - end, - {succeed_last,Val}. %Optimisation - -The second example is a function which returns the keys in an Ets -table on backtracking: - -ets_keys(Tab) -> - %% Solution with no look-ahead, get keys when requested. - %% This fun returns next key and itself for continuation. - F = fun (F1, Tab1, Last1) -> - case ets:next(Tab1, Last1) of - '$end_of_table' -> fail; %No more elements - Key1 -> {succeed,Key1, - fun () -> F1(F1, Tab1, Key1) end} - end - end, - case ets:first(Tab) of - '$end_of_table' -> fail; %No elements - Key -> {succeed,Key, fun () -> F(F, Tab, Key) end} - end. - -The third example calls a function which returns a list and returns -elements from this list on backtracking. I KNOW we could just return -the whole list and use member/2 to generate elements from it, but this -is more fun. - -get_list(ListGen) -> - %% This is what the operators will generate. - Vals = case ListGen of - {':',M,F} when is_atom(M), is_atom(F) -> M:F(); - {':',M,{F,A}} when is_atom(M), is_atom(F) -> M:F(A); - {':',M,T} when is_atom(M), is_tuple(T), size(T) >= 2, - is_atom(element(1, T)) -> - apply(M,element(1, T),tl(tuple_to_list(T))) - end, - %% This fun will return head and itself for continuation. - Fun = fun (F1, Es0) -> - case Es0 of - [E] -> {succeed_last,E}; %Optimisation - [E|Es] -> {succeed,E,fun () -> F1(F1, Es) end}; - [] -> fail %No more elements - end - end, - %Call with list of values to return first element. - Fun(Fun, Vals). - - -For example the Erlog goal: - - ecall(erlog_demo:get_list(ets:all),Tab), - ecall(erlog_demo:ets_keys(Tab),Key). - -will on backtracking generate the names of all ETS tables which have -keys and their keys. - -It is a great pity that the implementation of ETS loses greatly if you -want to do more complex selection of elements that just simple -matching. - -DEFINTE CLAUSE GRAMMERS (DCGs) - -Erlog supports DCGs. Expansion of -->/2 terms is done through the -procedure expand_term/2 which can be called explicitly and is called -automatically when consulting files. At present there is no support -for a user defined term_expansion/2 procedure. The expansion uses -phrase/3 to handle variable terms. This is defined by: - - phrase(Term, S0, S1) :- - Term =.. L, append(L, [S0,S1], L1), Call =.. L1, Call. - -PROLOG SYNTAX - -There is a simple Prolog parser, based on a Leex scanner and a -Standard Prolog parser, which will parse most Prolog terms. It -recognises all the standard operators, which have the default -priorities, but does not allow adding new operators. - -Files containing Prolog predicates can be consulted, however -directives and queries in the file are ignored. - -NOTES - -This is only a simple interpreter without a true garbage collector so -for larger evaluations you should adopt a failure driven style. - -There is no smart clause indexing on the first argument in a procedure -in Erlog. - -Yes, there are no I/O predicates provided. - -There is partial support for the equivalence of list notation and -'.'/2 terms, but it might go away later. - -We use the standard Erlang ordering of terms which means that -variables do not have the lowest ordering as they should. - -We use the Erlang definition of arithmetic operators, not standard -Prolog. - -Sometimes the description of the error returned from the parser can be -a little "cryptic". - -AUTHOR - -Robert Virding - robert.virding@telia.com -(with thanks to Richard O'Keefe for explaining some finer points of -the Prolog standard) diff --git a/ebin/erlog.app b/ebin/erlog.app deleted file mode 100644 index f4489ae..0000000 --- a/ebin/erlog.app +++ /dev/null @@ -1,20 +0,0 @@ -{application, erlog, - [{description, "Erlog , Prolog in Erlang"}, - {vsn, "0.6"}, - {modules, [erlog, - erlog_bips, - erlog_boot, - erlog_dcg, - erlog_demo, - erlog_ets, - erlog_file, - erlog_int, - erlog_io, - erlog_lists, - erlog_parse, - erlog_scan, - erlog_shell - ]}, - {registered, []}, - {applications, [kernel,stdlib]} - ]}. diff --git a/include/erlog.hrl b/include/erlog.hrl new file mode 100644 index 0000000..6a708c4 --- /dev/null +++ b/include/erlog.hrl @@ -0,0 +1,30 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 26. Нояб. 2014 18:32 +%%%------------------------------------------------------------------- +-author("tihon"). + +%% Database state +-record(db_state, +{ + stdlib :: dict, %kernel-space memory + exlib :: dict, %library-space memory + database :: atom(), % callback module for user-space memory + in_mem :: dict, %integrated memory for findall operations + state :: term() % callback state +}). + +%% Core state. +-record(state, +{ + db_state :: #db_state{}, %database state + f_consulter :: atom(), %file consulter + debugger :: fun(), %debugger function + e_man :: pid(), %event manager, used for debuging and other output (not for return) + state = normal :: normal | list(), %state for solution selecting. + libs_dir :: string() %path for directory, where prolog libs are stored +}). \ No newline at end of file diff --git a/include/erlog_bips.hrl b/include/erlog_bips.hrl new file mode 100644 index 0000000..bdda41e --- /dev/null +++ b/include/erlog_bips.hrl @@ -0,0 +1,47 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 17. Июль 2014 11:20 +%%%------------------------------------------------------------------- +-author("tihon"). + +-define(ERLOG_BIPS, + [ + %% Term unification and comparison + {'=', 2}, + {'\\=', 2}, + {'@>', 2}, + {'@>=', 2}, + {'==', 2}, + {'\\==', 2}, + {'@<', 2}, + {'@=<', 2}, + %% Term creation and decomposition. + {arg, 3}, + {copy_term, 2}, + {functor, 3}, + {'=..', 2}, + %% Type testing. + {atom, 1}, + {atomic, 1}, + {compound, 1}, + {integer, 1}, + {float, 1}, + {number, 1}, + {nonvar, 1}, + {var, 1}, + %% Atom processing. + {atom_chars, 2}, + {atom_length, 2}, + %% Arithmetic evaluation and comparison + {'is', 2}, + {'>', 2}, + {'>=', 2}, + {'=:=', 2}, + {'=\\=', 2}, + {'<', 2}, + {'=<', 2} + ]). \ No newline at end of file diff --git a/include/erlog_cache.hrl b/include/erlog_cache.hrl new file mode 100644 index 0000000..e807f87 --- /dev/null +++ b/include/erlog_cache.hrl @@ -0,0 +1,16 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 18. Авг. 2014 21:46 +%%%------------------------------------------------------------------- +-author("tihon"). + +-define(ERLOG_CACHE, + [ + {{put, 2}, ?MODULE, put_2}, + {{get, 2}, ?MODULE, get_2} + ] +). \ No newline at end of file diff --git a/include/erlog_core.hrl b/include/erlog_core.hrl new file mode 100644 index 0000000..15866c4 --- /dev/null +++ b/include/erlog_core.hrl @@ -0,0 +1,107 @@ +%% Copyright (c) 2008-2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : erlog_int.erl +%% Author : Robert Virding +%% Purpose : Basic interpreter of a Prolog definitions. + +%% Some standard type macros. +-define(IS_ATOMIC(T), (not (is_tuple(T) orelse (is_list(T) andalso T /= [])))). +-define(IS_FUNCTOR(T), (is_tuple(T) andalso (tuple_size(T) >= 2) andalso is_atom(element(1, T)))). + +%% The old is_constant/1 ? +-define(IS_CONSTANT(T), (not (is_tuple(T) orelse is_list(T)))). + +%%-define(BIND, orddict) +-define(BIND, dict). + +%% Define the choice point record +-record(cp, {type, label, data, next, bs, vn}). +-record(cut, {label, next}). + +%% record for passing arguments to erlog_core:prove_goal +-record(param, +{ + goal, + next_goal, + choice, + bindings, + var_num, + database, %erlog.htl db_state + event_man, + f_consulter :: atom(), + debugger, + cursor, + libs_dir +}). + +-define(ERLOG_CORE, + [ + %% Logic and control. + {call, 1}, + {',', 2}, + {'!', 0}, + {';', 2}, + {fail, 0}, + {'->', 2}, + {'\\+', 1}, + {once, 1}, + {repeat, 0}, + {true, 0}, + %% Clause creation and destruction. + {abolish, 1}, + {assert, 1}, + {asserta, 1}, + {assertz, 1}, + {retract, 1}, + {retractall, 1}, + %% Clause retrieval and information. + {clause, 2}, + {current_predicate, 1}, + {predicate_property, 2}, + %% All solutions + %% External interface + {ecall, 2}, + %% File utils + {consult, 1}, + {reconsult, 1}, + {deconsult, 1}, %remove functors in file from memory + %% Debug functions + {writeln, 1}, + %% Searching functions + {findall, 3}, + {findall, 2}, %support for findall + {bagof, 3}, + {setof, 3}, + {listing, 1}, + {listing, 2}, + {listing, 3}, + %% Non standart functions + {use, 1}, %load erlang library module + {to_integer, 2}, + {to_string, 2} + ] +). + +-define(STDLIB, + [ + erlog_core, %Core predicates + erlog_bips, %Built in predicates + erlog_dcg, %DCG predicates + erlog_lists, %Common lists library + erlog_time, %Bindings for working with data and time + erlog_string, %Bindings for working with strings + erlog_math %Predicates for working with math utils + ] +). \ No newline at end of file diff --git a/include/erlog_db.hrl b/include/erlog_db.hrl new file mode 100644 index 0000000..2739960 --- /dev/null +++ b/include/erlog_db.hrl @@ -0,0 +1,24 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 17. Июль 2014 11:19 +%%%------------------------------------------------------------------- +-author("tihon"). + +-define(ERLOG_DB, + [ + {{db_abolish, 2}, ?MODULE, db_abolish_2}, + {{db_assert, 2}, ?MODULE, db_assert_2}, + {{db_asserta, 2}, ?MODULE, db_asserta_2}, + {{db_assertz, 2}, ?MODULE, db_assert_2}, + {{db_retract, 2}, ?MODULE, db_retract_2}, + {{db_retractall, 2}, ?MODULE, db_retractall_2}, + {{db_call, 2}, ?MODULE, db_call_2}, + {{db_listing, 2}, ?MODULE, db_listing_2}, + {{db_listing, 3}, ?MODULE, db_listing_3}, + {{db_listing, 4}, ?MODULE, db_listing_4} + ] +). \ No newline at end of file diff --git a/include/erlog_dcg.hrl b/include/erlog_dcg.hrl new file mode 100644 index 0000000..70f3184 --- /dev/null +++ b/include/erlog_dcg.hrl @@ -0,0 +1,15 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 17. Июль 2014 11:20 +%%%------------------------------------------------------------------- +-author("tihon"). + +-define(ERLOG_DCG, + [ + {expand_term, 2}, + {phrase, 3} + ]). \ No newline at end of file diff --git a/include/erlog_lists.hrl b/include/erlog_lists.hrl new file mode 100644 index 0000000..950c12d --- /dev/null +++ b/include/erlog_lists.hrl @@ -0,0 +1,20 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 17. Июль 2014 11:19 +%%%------------------------------------------------------------------- +-author("tihon"). + +-define(ERLOG_LISTS, + [ + {append, 3}, + {insert, 3}, + {member, 2}, + {memberchk, 2}, + {reverse, 2}, + {sort, 2}, + {length, 2} + ]). \ No newline at end of file diff --git a/include/erlog_math.hrl b/include/erlog_math.hrl new file mode 100644 index 0000000..1c537b3 --- /dev/null +++ b/include/erlog_math.hrl @@ -0,0 +1,14 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 17. Июль 2014 11:19 +%%%------------------------------------------------------------------- +-author("tihon"). + +-define(ERLOG_MATH, + [ + {round, 3} + ]). \ No newline at end of file diff --git a/include/erlog_parallel.hrl b/include/erlog_parallel.hrl new file mode 100644 index 0000000..552ab8b --- /dev/null +++ b/include/erlog_parallel.hrl @@ -0,0 +1,16 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2015, +%%% @doc +%%% +%%% @end +%%% Created : 30. Янв. 2015 20:06 +%%%------------------------------------------------------------------- +-author("tihon"). + +-define(ERLOG_PARALLEL, + [ + {spawn, 2}, %spawn goal processing in a new thread + {join, 2}, %wait for thread (or multiple threads) + {check, 2} %get result of thread by pid + ]). \ No newline at end of file diff --git a/include/erlog_string.hrl b/include/erlog_string.hrl new file mode 100644 index 0000000..101ce79 --- /dev/null +++ b/include/erlog_string.hrl @@ -0,0 +1,20 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 22. Окт. 2014 20:56 +%%%------------------------------------------------------------------- +-author("tihon"). + +-define(ERLOG_STRING, + [ + {concat, 2}, + {substring, 4}, + {indexof, 3}, + {split, 3}, + {parse_int, 2}, + {parse_float, 2}, + {str_number, 2} + ]). \ No newline at end of file diff --git a/include/erlog_time.hrl b/include/erlog_time.hrl new file mode 100644 index 0000000..8079289 --- /dev/null +++ b/include/erlog_time.hrl @@ -0,0 +1,26 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 17. Июль 2014 11:19 +%%%------------------------------------------------------------------- +-author("tihon"). + +-define(MONTHS, {"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", + "Aug", "Sep", "Oct", "Nov", "Dec"}). +-define(MONTH(X), element(X, ?MONTHS)). + +-define(ERLOG_TIME, + [ + {localtime, 1}, + {date_diff, 4}, + {add_time, 4}, + {date_print, 2}, + {date_parse, 2}, + {date, 2}, + {date, 4}, + {time, 2}, + {time, 4} + ]). \ No newline at end of file diff --git a/lib/autoload/lists.pl b/lib/autoload/lists.pl new file mode 100644 index 0000000..037c6e1 --- /dev/null +++ b/lib/autoload/lists.pl @@ -0,0 +1,2 @@ +perm([], []). +perm([X|Xs], Ys1) :- perm(Xs, Ys), insert(Ys, X, Ys1). diff --git a/rebar.config b/rebar.config new file mode 100644 index 0000000..b318795 --- /dev/null +++ b/rebar.config @@ -0,0 +1,16 @@ +%% rel dirs +{sub_dirs, ["rel"]}. + +%% compiler options +{ + erl_opts, + [ + no_debug_info, + fail_on_warning + ] +}. + +%% deps +{ + deps, [] +}. \ No newline at end of file diff --git a/rel/files/erl b/rel/files/erl new file mode 100644 index 0000000..f4c63af --- /dev/null +++ b/rel/files/erl @@ -0,0 +1,44 @@ +#!/bin/sh + +# /bin/sh on Solaris is not a POSIX compatible shell, but /usr/bin/ksh is. +if [ `uname -s` = 'SunOS' -a "${POSIX_SHELL}" != "true" ]; then + POSIX_SHELL="true" + export POSIX_SHELL + exec /usr/bin/ksh $0 "$@" +fi + +# clear it so if we invoke other scripts, they run as ksh as well +unset POSIX_SHELL + +## This script replaces the default "erl" in erts-VSN/bin. This is +## necessary as escript depends on erl and in turn, erl depends on +## having access to a bootscript (start.boot). Note that this script +## is ONLY invoked as a side-effect of running escript -- the embedded +## node bypasses erl and uses erlexec directly (as it should). +## +## Note that this script makes the assumption that there is a +## start_clean.boot file available in $ROOTDIR/release/VSN. + +# Determine the abspath of where this script is executing from. +ERTS_BIN_DIR=$(cd ${0%/*} && pwd -P) + +# Now determine the root directory -- this script runs from erts-VSN/bin, +# so we simply need to strip off two dirs from the end of the ERTS_BIN_DIR +# path. +ROOTDIR=${ERTS_BIN_DIR%/*/*} + +# Parse out release and erts info +START_ERL=`cat $ROOTDIR/releases/start_erl.data` +ERTS_VSN=${START_ERL% *} +APP_VSN=${START_ERL#* } + +BINDIR=$ROOTDIR/erts-$ERTS_VSN/bin +EMU=beam +PROGNAME=`echo $0 | sed 's/.*\\///'` +CMD="$BINDIR/erlexec" +export EMU +export ROOTDIR +export BINDIR +export PROGNAME + +exec $CMD -boot $ROOTDIR/releases/$APP_VSN/start_clean ${1+"$@"} diff --git a/rel/files/erlog b/rel/files/erlog new file mode 100644 index 0000000..c2ef258 --- /dev/null +++ b/rel/files/erlog @@ -0,0 +1,347 @@ +#!/bin/sh +# -*- tab-width:4;indent-tabs-mode:nil -*- +# ex: ts=4 sw=4 et + +# /bin/sh on Solaris is not a POSIX compatible shell, but /usr/bin/ksh is. +if [ `uname -s` = 'SunOS' -a "${POSIX_SHELL}" != "true" ]; then + POSIX_SHELL="true" + export POSIX_SHELL + # To support 'whoami' add /usr/ucb to path + PATH=/usr/ucb:$PATH + export PATH + exec /usr/bin/ksh $0 "$@" +fi + +# clear it so if we invoke other scripts, they run as ksh +unset POSIX_SHELL + +RUNNER_SCRIPT_DIR=$(cd ${0%/*} && pwd -P) + +CALLER_DIR=$PWD + +RUNNER_BASE_DIR=${RUNNER_SCRIPT_DIR%/*} +RUNNER_ETC_DIR=$RUNNER_BASE_DIR/etc +# Note the trailing slash on $PIPE_DIR/ +PIPE_DIR=/tmp/$RUNNER_BASE_DIR/ +RUNNER_USER= +WHOAMI=$(whoami) + +# Make sure this script is running as the appropriate user +if ([ "$RUNNER_USER" ] && [ "x$WHOAMI" != "x$RUNNER_USER" ]); then + type sudo > /dev/null 2>&1 + if [ $? -ne 0 ]; then + echo "sudo doesn't appear to be installed and your EUID isn't $RUNNER_USER" 1>&2 + exit 1 + fi + echo "Attempting to restart script through sudo -H -u $RUNNER_USER" >&2 + exec sudo -H -u $RUNNER_USER -i $RUNNER_SCRIPT_DIR/$RUNNER_SCRIPT $@ +fi + +# Identify the script name +SCRIPT=`basename $0` + +# Parse out release and erts info +START_ERL=`cat $RUNNER_BASE_DIR/releases/start_erl.data` +ERTS_VSN=${START_ERL% *} +APP_VSN=${START_ERL#* } + +# Use $CWD/vm.args if exists, otherwise releases/APP_VSN/vm.args, or +# else etc/vm.args +if [ -e "$CALLER_DIR/vm.args" ]; then + VMARGS_PATH=$CALLER_DIR/vm.args + USE_DIR=$CALLER_DIR +else + USE_DIR=$RUNNER_BASE_DIR + if [ -e "$RUNNER_BASE_DIR/releases/$APP_VSN/vm.args" ]; then + VMARGS_PATH="$RUNNER_BASE_DIR/releases/$APP_VSN/vm.args" + else + VMARGS_PATH="$RUNNER_ETC_DIR/vm.args" + fi +fi + +RUNNER_LOG_DIR=$USE_DIR/log +# Make sure log directory exists +mkdir -p $RUNNER_LOG_DIR + +# Use releases/VSN/sys.config if it exists otherwise use etc/app.config +if [ -e "$USE_DIR/sys.config" ]; then + CONFIG_PATH="$USE_DIR/sys.config" +else + if [ -e "$RUNNER_BASE_DIR/releases/$APP_VSN/sys.config" ]; then + CONFIG_PATH="$RUNNER_BASE_DIR/releases/$APP_VSN/sys.config" + else + CONFIG_PATH="$RUNNER_ETC_DIR/app.config" + fi +fi + +# Extract the target node name from node.args +NAME_ARG=`egrep '^\-s?name' $VMARGS_PATH` +if [ -z "$NAME_ARG" ]; then + echo "vm.args needs to have either -name or -sname parameter." + exit 1 +fi + +# Extract the name type and name from the NAME_ARG for REMSH +REMSH_TYPE=`echo $NAME_ARG | awk '{print $1}'` +REMSH_NAME=`echo $NAME_ARG | awk '{print $2}'` + +# Note the `date +%s`, used to allow multiple remsh to the same node +# transparently +REMSH_NAME_ARG="$REMSH_TYPE remsh`date +%s`@`echo $REMSH_NAME | awk -F@ '{print $2}'`" +REMSH_REMSH_ARG="-remsh $REMSH_NAME" + +# Extract the target cookie +COOKIE_ARG=`grep '^\-setcookie' $VMARGS_PATH` +if [ -z "$COOKIE_ARG" ]; then + echo "vm.args needs to have a -setcookie parameter." + exit 1 +fi + +# Make sure CWD is set to the right dir +cd $USE_DIR + +# Make sure log directory exists +mkdir -p $USE_DIR/log + +# Add ERTS bin dir to our path +ERTS_PATH=$RUNNER_BASE_DIR/erts-$ERTS_VSN/bin + +# Setup command to control the node +NODETOOL="$ERTS_PATH/escript $ERTS_PATH/nodetool $NAME_ARG $COOKIE_ARG" + +# Setup remote shell command to control node +REMSH="$ERTS_PATH/erl $REMSH_NAME_ARG $REMSH_REMSH_ARG $COOKIE_ARG" + +# Common functions + +# Ping node without allowing nodetool to take stdin +ping_node() { + $NODETOOL ping < /dev/null +} + +# Set the PID global variable, return 1 on error +get_pid() { + PID=`$NODETOOL getpid < /dev/null` + ES=$? + if [ "$ES" -ne 0 ]; then + echo "Node is not running!" + return 1 + fi + + # don't allow empty or init pid's + if [ -z $PID ] || [ "$PID" -le 1 ]; then + return 1 + fi + + return 0 +} + +# Check the first argument for instructions +case "$1" in + start|start_boot) + # Make sure there is not already a node running + RES=`ping_node` + if [ "$RES" = "pong" ]; then + echo "Node is already running!" + exit 1 + fi + case "$1" in + start) + shift + START_OPTION="console" + HEART_OPTION="start" + ;; + start_boot) + shift + START_OPTION="console_boot" + HEART_OPTION="start_boot" + ;; + esac + RUN_PARAM=$(printf "\'%s\' " "$@") + HEART_COMMAND="$RUNNER_BASE_DIR/bin/$SCRIPT $HEART_OPTION $RUN_PARAM" + export HEART_COMMAND + mkdir -p $PIPE_DIR + $ERTS_PATH/run_erl -daemon $PIPE_DIR $RUNNER_LOG_DIR "exec $RUNNER_BASE_DIR/bin/$SCRIPT $START_OPTION $RUN_PARAM" 2>&1 + ;; + + stop) + # Wait for the node to completely stop... + case `uname -s` in + Darwin) + # Make sure we explicitly set this because iTerm.app doesn't for + # some reason. + COMMAND_MODE=unix2003 + esac + + # Get the PID from nodetool + get_pid + GPR=$? + if [ "$GPR" -ne 0 ] || [ -z $PID ]; then + exit $GPR + fi + + # Tell nodetool to initiate a stop + $NODETOOL stop + ES=$? + if [ "$ES" -ne 0 ]; then + exit $ES + fi + + # Wait for the node to completely stop... + while `kill -s 0 $PID 2>/dev/null` + do + sleep 1 + done + ;; + + restart) + ## Restart the VM without exiting the process + $NODETOOL restart + ES=$? + if [ "$ES" -ne 0 ]; then + exit $ES + fi + ;; + + reboot) + ## Restart the VM completely (uses heart to restart it) + $NODETOOL reboot + ES=$? + if [ "$ES" -ne 0 ]; then + exit $ES + fi + ;; + + ping) + ## See if the VM is alive + ping_node + ES=$? + if [ "$ES" -ne 0 ]; then + exit $ES + fi + ;; + + attach) + # Make sure a node is running + ping_node + ES=$? + if [ "$ES" -ne 0 ]; then + echo "Node is not running!" + exit $ES + fi + + shift + exec $ERTS_PATH/to_erl $PIPE_DIR + ;; + + remote_console) + # Make sure a node is running + ping_node + ES=$? + if [ "$ES" -ne 0 ]; then + echo "Node is not running!" + exit $ES + fi + + shift + exec $REMSH + ;; + + upgrade) + if [ -z "$2" ]; then + echo "Missing upgrade package argument" + echo "Usage: $SCRIPT upgrade {package base name}" + echo "NOTE {package base name} MUST NOT include the .tar.gz suffix" + exit 1 + fi + + # Make sure a node IS running + ping_node + ES=$? + if [ "$ES" -ne 0 ]; then + echo "Node is not running!" + exit $ES + fi + + node_name=`echo $NAME_ARG | awk '{print $2}'` + erlang_cookie=`echo $COOKIE_ARG | awk '{print $2}'` + + $ERTS_PATH/escript $RUNNER_BASE_DIR/bin/install_upgrade.escript $node_name $erlang_cookie $2 + ;; + + console|console_clean|console_boot) + # .boot file typically just $SCRIPT (ie, the app name) + # however, for debugging, sometimes start_clean.boot is useful. + # For e.g. 'setup', one may even want to name another boot script. + case "$1" in + console) BOOTFILE=$SCRIPT ;; + console_clean) BOOTFILE=start_clean ;; + console_boot) + shift + BOOTFILE="$1" + shift + ;; + esac + # Setup beam-required vars + ROOTDIR=$RUNNER_BASE_DIR + BINDIR=$ROOTDIR/erts-$ERTS_VSN/bin + EMU=beam + PROGNAME=`echo $0 | sed 's/.*\\///'` + CMD="$BINDIR/erlexec -boot $RUNNER_BASE_DIR/releases/$APP_VSN/$BOOTFILE -mode embedded -config $CONFIG_PATH -args_file $VMARGS_PATH" + export EMU + export ROOTDIR + export BINDIR + export PROGNAME + + # Dump environment info for logging purposes + echo "Exec: $CMD" -- ${1+"$@"} + echo "Root: $ROOTDIR" + + # Log the startup + logger -t "$SCRIPT[$$]" "Starting up" + + # Start the VM + exec $CMD -- ${1+"$@"} + ;; + + foreground) + # start up the release in the foreground for use by runit + # or other supervision services + + BOOTFILE=$SCRIPT + FOREGROUNDOPTIONS="-noinput +Bd" + + # Setup beam-required vars + ROOTDIR=$RUNNER_BASE_DIR + BINDIR=$ROOTDIR/erts-$ERTS_VSN/bin + EMU=beam + PROGNAME=`echo $0 | sed 's/.*\///'` + CMD="$BINDIR/erlexec $FOREGROUNDOPTIONS -boot $RUNNER_BASE_DIR/releases/$APP_VSN/$BOOTFILE -config $CONFIG_PATH -args_file $VMARGS_PATH" + export EMU + export ROOTDIR + export BINDIR + export PROGNAME + + # Dump environment info for logging purposes + echo "Exec: $CMD" -- ${1+"$@"} + echo "Root: $ROOTDIR" + + # Start the VM + exec $CMD -- ${1+"$@"} + ;; + getpid) + # Get the PID from nodetool + get_pid + ES=$? + if [ "$ES" -ne 0 ] || [ -z $PID ]; then + exit $ES + fi + echo $PID + ;; + *) + echo "Usage: $SCRIPT {start|start_boot |foreground|stop|restart|reboot|ping|console|getpid|console_clean|console_boot |attach|remote_console|upgrade}" + exit 1 + ;; +esac + +exit 0 diff --git a/rel/files/erlog.cmd b/rel/files/erlog.cmd new file mode 100644 index 0000000..1abf13d --- /dev/null +++ b/rel/files/erlog.cmd @@ -0,0 +1,103 @@ +@setlocal + +@set node_name=erlog + +@rem Get the absolute path to the parent directory, +@rem which is assumed to be the node root. +@for /F "delims=" %%I in ("%~dp0..") do @set node_root=%%~fI + +@set releases_dir=%node_root%\releases + +@rem Parse ERTS version and release version from start_erl.data +@for /F "usebackq tokens=1,2" %%I in ("%releases_dir%\start_erl.data") do @( + @call :set_trim erts_version %%I + @call :set_trim release_version %%J +) + +@set vm_args=%releases_dir%\%release_version%\vm.args +@set sys_config=%releases_dir%\%release_version%\sys.config +@set node_boot_script=%releases_dir%\%release_version%\%node_name% +@set clean_boot_script=%releases_dir%\%release_version%\start_clean + +@rem extract erlang cookie from vm.args +@for /f "usebackq tokens=1-2" %%I in (`findstr /b \-setcookie "%vm_args%"`) do @set erlang_cookie=%%J + +@set erts_bin=%node_root%\erts-%erts_version%\bin + +@set service_name=%node_name%_%release_version% + +@set erlsrv="%erts_bin%\erlsrv.exe" +@set epmd="%erts_bin%\epmd.exe" +@set escript="%erts_bin%\escript.exe" +@set werl="%erts_bin%\werl.exe" +@set nodetool="%erts_bin%\nodetool" + +@if "%1"=="usage" @goto usage +@if "%1"=="install" @goto install +@if "%1"=="uninstall" @goto uninstall +@if "%1"=="start" @goto start +@if "%1"=="stop" @goto stop +@if "%1"=="restart" @call :stop && @goto start +@if "%1"=="console" @goto console +@if "%1"=="ping" @goto ping +@if "%1"=="query" @goto query +@if "%1"=="attach" @goto attach +@if "%1"=="upgrade" @goto upgrade +@echo Unknown command: "%1" + +:usage +@echo Usage: %~n0 [install^|uninstall^|start^|stop^|restart^|console^|ping^|query^|attach^|upgrade] +@goto :EOF + +:install +@set description=Erlang node %node_name% in %node_root% +@set start_erl=%node_root%\bin\start_erl.cmd +@set args= ++ %node_name% ++ %node_root% +@%erlsrv% add %service_name% -c "%description%" -sname %node_name% -w "%node_root%" -m "%start_erl%" -args "%args%" -stopaction "init:stop()." +@goto :EOF + +:uninstall +@%erlsrv% remove %service_name% +@%epmd% -kill +@goto :EOF + +:start +@%erlsrv% start %service_name% +@goto :EOF + +:stop +@%erlsrv% stop %service_name% +@goto :EOF + +:console +@start "%node_name% console" %werl% -boot "%node_boot_script%" -config "%sys_config%" -args_file "%vm_args%" -sname %node_name% +@goto :EOF + +:ping +@%escript% %nodetool% ping -sname "%node_name%" -setcookie "%erlang_cookie%" +@exit %ERRORLEVEL% +@goto :EOF + +:query +@%erlsrv% list %service_name% +@exit %ERRORLEVEL% +@goto :EOF + +:attach +@for /f "usebackq" %%I in (`hostname`) do @set hostname=%%I +start "%node_name% attach" %werl% -boot "%clean_boot_script%" -remsh %node_name%@%hostname% -sname console -setcookie %erlang_cookie% +@goto :EOF + +:upgrade +@if "%2"=="" ( + @echo Missing upgrade package argument + @echo Usage: %~n0 upgrade {package base name} + @echo NOTE {package base name} MUST NOT include the .tar.gz suffix + @goto :EOF +) +@%escript% %node_root%\bin\install_upgrade.escript %node_name% %erlang_cookie% %2 +@goto :EOF + +:set_trim +@set %1=%2 +@goto :EOF diff --git a/rel/files/install_upgrade.escript b/rel/files/install_upgrade.escript new file mode 100644 index 0000000..56cea19 --- /dev/null +++ b/rel/files/install_upgrade.escript @@ -0,0 +1,44 @@ +#!/usr/bin/env escript +%%! -noshell -noinput +%% -*- mode: erlang;erlang-indent-level: 4;indent-tabs-mode: nil -*- +%% ex: ft=erlang ts=4 sw=4 et + +-define(TIMEOUT, 60000). +-define(INFO(Fmt,Args), io:format(Fmt,Args)). + +main([NodeName, Cookie, ReleasePackage]) -> + TargetNode = start_distribution(NodeName, Cookie), + {ok, Vsn} = rpc:call(TargetNode, release_handler, unpack_release, + [ReleasePackage], ?TIMEOUT), + ?INFO("Unpacked Release ~p~n", [Vsn]), + {ok, OtherVsn, Desc} = rpc:call(TargetNode, release_handler, + check_install_release, [Vsn], ?TIMEOUT), + {ok, OtherVsn, Desc} = rpc:call(TargetNode, release_handler, + install_release, [Vsn], ?TIMEOUT), + ?INFO("Installed Release ~p~n", [Vsn]), + ok = rpc:call(TargetNode, release_handler, make_permanent, [Vsn], ?TIMEOUT), + ?INFO("Made Release ~p Permanent~n", [Vsn]); +main(_) -> + init:stop(1). + +start_distribution(NodeName, Cookie) -> + MyNode = make_script_node(NodeName), + {ok, _Pid} = net_kernel:start([MyNode, shortnames]), + erlang:set_cookie(node(), list_to_atom(Cookie)), + TargetNode = make_target_node(NodeName), + case {net_kernel:hidden_connect_node(TargetNode), + net_adm:ping(TargetNode)} of + {true, pong} -> + ok; + {_, pang} -> + io:format("Node ~p not responding to pings.\n", [TargetNode]), + init:stop(1) + end, + TargetNode. + +make_target_node(Node) -> + [_, Host] = string:tokens(atom_to_list(node()), "@"), + list_to_atom(lists:concat([Node, "@", Host])). + +make_script_node(Node) -> + list_to_atom(lists:concat([Node, "_upgrader_", os:getpid()])). diff --git a/rel/files/nodetool b/rel/files/nodetool new file mode 100644 index 0000000..ce06c6a --- /dev/null +++ b/rel/files/nodetool @@ -0,0 +1,182 @@ +#!/usr/bin/env escript +%% -*- mode: erlang;erlang-indent-level: 4;indent-tabs-mode: nil -*- +%% ex: ft=erlang ts=4 sw=4 et +%% ------------------------------------------------------------------- +%% +%% nodetool: Helper Script for interacting with live nodes +%% +%% ------------------------------------------------------------------- +main(Args) -> + ok = start_epmd(), + %% Extract the args + {RestArgs, TargetNode} = process_args(Args, [], undefined), + + %% any commands that don't need a running node + case RestArgs of + ["chkconfig", File] -> + case file:consult(File) of + {ok, _} -> + io:format("ok\n"), + halt(0); + {error, {Line, Mod, Term}} -> + io:format(standard_error, ["Error on line ", + file:format_error({Line, Mod, Term}), "\n"], []), + halt(1); + {error, R} -> + io:format(standard_error, ["Error reading config file: ", + file:format_error(R), "\n"], []), + halt(1) + end; + _ -> + ok + end, + + %% See if the node is currently running -- if it's not, we'll bail + case {net_kernel:hidden_connect_node(TargetNode), + net_adm:ping(TargetNode)} of + {true, pong} -> + ok; + {false,pong} -> + io:format("Failed to connect to node ~p .\n", [TargetNode]), + halt(1); + {_, pang} -> + io:format("Node ~p not responding to pings.\n", [TargetNode]), + halt(1) + end, + + case RestArgs of + ["getpid"] -> + io:format("~p\n", + [list_to_integer(rpc:call(TargetNode, os, getpid, []))]); + ["ping"] -> + %% If we got this far, the node already responsed to a + %% ping, so just dump a "pong" + io:format("pong\n"); + ["stop"] -> + io:format("~p\n", [rpc:call(TargetNode, init, stop, [], 60000)]); + ["restart"] -> + io:format("~p\n", [rpc:call(TargetNode, init, restart, [], 60000)]); + ["reboot"] -> + io:format("~p\n", [rpc:call(TargetNode, init, reboot, [], 60000)]); + ["rpc", Module, Function | RpcArgs] -> + case rpc:call(TargetNode, + list_to_atom(Module), + list_to_atom(Function), + [RpcArgs], 60000) of + ok -> + ok; + {badrpc, Reason} -> + io:format("RPC to ~p failed: ~p\n", [TargetNode, Reason]), + halt(1); + _ -> + halt(1) + end; + ["rpc_infinity", Module, Function | RpcArgs] -> + case rpc:call(TargetNode, + list_to_atom(Module), + list_to_atom(Function), + [RpcArgs], infinity) of + ok -> + ok; + {badrpc, Reason} -> + io:format("RPC to ~p failed: ~p\n", [TargetNode, Reason]), + halt(1); + _ -> + halt(1) + end; + ["rpcterms", Module, Function, ArgsAsString] -> + case rpc:call(TargetNode, + list_to_atom(Module), + list_to_atom(Function), + consult(ArgsAsString), 60000) of + {badrpc, Reason} -> + io:format("RPC to ~p failed: ~p\n", [TargetNode, Reason]), + halt(1); + Other -> + io:format("~p\n", [Other]) + end; + Other -> + io:format("Other: ~p\n", [Other]), + io:format("Usage: nodetool {chkconfig|getpid|ping|stop|restart|reboot|rpc|rpc_infinity|rpcterms}\n") + end, + net_kernel:stop(). + +process_args([], Acc, TargetNode) -> + {lists:reverse(Acc), TargetNode}; +process_args(["-setcookie", Cookie | Rest], Acc, TargetNode) -> + erlang:set_cookie(node(), list_to_atom(Cookie)), + process_args(Rest, Acc, TargetNode); +process_args(["-name", TargetName | Rest], Acc, _) -> + ThisNode = append_node_suffix(TargetName, "_maint_"), + {ok, _} = net_kernel:start([ThisNode, longnames]), + process_args(Rest, Acc, nodename(TargetName)); +process_args(["-sname", TargetName | Rest], Acc, _) -> + ThisNode = append_node_suffix(TargetName, "_maint_"), + {ok, _} = net_kernel:start([ThisNode, shortnames]), + process_args(Rest, Acc, nodename(TargetName)); +process_args([Arg | Rest], Acc, Opts) -> + process_args(Rest, [Arg | Acc], Opts). + + +start_epmd() -> + [] = os:cmd(epmd_path() ++ " -daemon"), + ok. + +epmd_path() -> + ErtsBinDir = filename:dirname(escript:script_name()), + Name = "epmd", + case os:find_executable(Name, ErtsBinDir) of + false -> + case os:find_executable(Name) of + false -> + io:format("Could not find epmd.~n"), + halt(1); + GlobalEpmd -> + GlobalEpmd + end; + Epmd -> + Epmd + end. + + +nodename(Name) -> + case string:tokens(Name, "@") of + [_Node, _Host] -> + list_to_atom(Name); + [Node] -> + [_, Host] = string:tokens(atom_to_list(node()), "@"), + list_to_atom(lists:concat([Node, "@", Host])) + end. + +append_node_suffix(Name, Suffix) -> + case string:tokens(Name, "@") of + [Node, Host] -> + list_to_atom(lists:concat([Node, Suffix, os:getpid(), "@", Host])); + [Node] -> + list_to_atom(lists:concat([Node, Suffix, os:getpid()])) + end. + + +%% +%% Given a string or binary, parse it into a list of terms, ala file:consult/0 +%% +consult(Str) when is_list(Str) -> + consult([], Str, []); +consult(Bin) when is_binary(Bin)-> + consult([], binary_to_list(Bin), []). + +consult(Cont, Str, Acc) -> + case erl_scan:tokens(Cont, Str, 0) of + {done, Result, Remaining} -> + case Result of + {ok, Tokens, _} -> + {ok, Term} = erl_parse:parse_term(Tokens), + consult([], Remaining, [Term | Acc]); + {eof, _Other} -> + lists:reverse(Acc); + {error, Info, _} -> + {error, Info} + end; + {more, Cont1} -> + consult(Cont1, eof, Acc) + end. diff --git a/rel/files/start_erl.cmd b/rel/files/start_erl.cmd new file mode 100644 index 0000000..c0f2072 --- /dev/null +++ b/rel/files/start_erl.cmd @@ -0,0 +1,40 @@ +@setlocal + +@rem Parse arguments. erlsrv.exe prepends erl arguments prior to first ++. +@rem Other args are position dependent. +@set args="%*" +@for /F "delims=++ tokens=1,2,3" %%I in (%args%) do @( + @set erl_args=%%I + @call :set_trim node_name %%J + @rem Trim spaces from the left of %%K (node_root), which may have spaces inside + @for /f "tokens=* delims= " %%a in ("%%K") do @set node_root=%%a +) + +@set releases_dir=%node_root%\releases + +@rem parse ERTS version and release version from start_erl.dat +@for /F "usebackq tokens=1,2" %%I in ("%releases_dir%\start_erl.data") do @( + @call :set_trim erts_version %%I + @call :set_trim release_version %%J +) + +@set erl_exe="%node_root%\erts-%erts_version%\bin\erl.exe" +@set boot_file="%releases_dir%\%release_version%\%node_name%" + +@if exist "%releases_dir%\%release_version%\sys.config" ( + @set app_config="%releases_dir%\%release_version%\sys.config" +) else ( + @set app_config="%node_root%\etc\app.config" +) + +@if exist "%releases_dir%\%release_version%\vm.args" ( + @set vm_args="%releases_dir%\%release_version%\vm.args" +) else ( + @set vm_args="%node_root%\etc\vm.args" +) + +@%erl_exe% %erl_args% -boot %boot_file% -config %app_config% -args_file %vm_args% + +:set_trim +@set %1=%2 +@goto :EOF diff --git a/rel/files/sys.config b/rel/files/sys.config new file mode 100644 index 0000000..3b7f6bd --- /dev/null +++ b/rel/files/sys.config @@ -0,0 +1,11 @@ +[ + %% SASL config + {sasl, [ + {sasl_error_logger, {file, "log/sasl-error.log"}}, + {errlog_type, error}, + {error_logger_mf_dir, "log/sasl"}, % Log directory + {error_logger_mf_maxbytes, 10485760}, % 10 MB max file size + {error_logger_mf_maxfiles, 5} % 5 files max + ]} +]. + diff --git a/rel/files/vm.args b/rel/files/vm.args new file mode 100644 index 0000000..f258ed7 --- /dev/null +++ b/rel/files/vm.args @@ -0,0 +1,19 @@ +## Name of the node +-name erlog@127.0.0.1 + +## Cookie for distributed erlang +-setcookie erlog + +## Heartbeat management; auto-restarts VM if it dies or becomes unresponsive +## (Disabled by default..use with caution!) +##-heart + +## Enable kernel poll and a few async threads +##+K true +##+A 5 + +## Increase number of concurrent ports/sockets +##-env ERL_MAX_PORTS 4096 + +## Tweak GC to run more often +##-env ERL_FULLSWEEP_AFTER 10 diff --git a/rel/reltool.config b/rel/reltool.config new file mode 100644 index 0000000..56a665a --- /dev/null +++ b/rel/reltool.config @@ -0,0 +1,44 @@ +%% -*- mode: erlang -*- +%% ex: ft=erlang +{sys, [ + {lib_dirs, []}, + {erts, [{mod_cond, derived}, {app_file, strip}]}, + {app_file, strip}, + {rel, "erlog", "0.6", + [ + kernel, + stdlib, + sasl, + erlog + ]}, + {rel, "start_clean", "", + [ + kernel, + stdlib + ]}, + {boot_rel, "erlog"}, + {profile, embedded}, + {incl_cond, derived}, + {excl_archive_filters, [".*"]}, %% Do not archive built libs + {excl_sys_filters, ["^bin/(?!start_clean.boot)", + "^erts.*/bin/(dialyzer|typer)", + "^erts.*/(doc|info|include|lib|man|src)"]}, + {excl_app_filters, ["\.gitignore"]}, + {app, erlog, [{mod_cond, app}, {incl_cond, include}, {lib_dir, ".."}]} +]}. + +{target_dir, "erlog"}. + +{overlay, [ + {mkdir, "log/sasl"}, + {copy, "files/erl", "\{\{erts_vsn\}\}/bin/erl"}, + {copy, "files/nodetool", "\{\{erts_vsn\}\}/bin/nodetool"}, + {copy, "erlog/bin/start_clean.boot", + "\{\{erts_vsn\}\}/bin/start_clean.boot"}, + {copy, "files/erlog", "bin/erlog"}, + {copy, "files/erlog.cmd", "bin/erlog.cmd"}, + {copy, "files/start_erl.cmd", "bin/start_erl.cmd"}, + {copy, "files/install_upgrade.escript", "bin/install_upgrade.escript"}, + {copy, "files/sys.config", "releases/\{\{rel_vsn\}\}/sys.config"}, + {copy, "files/vm.args", "releases/\{\{rel_vsn\}\}/vm.args"} +]}. diff --git a/src/core/erlog.erl b/src/core/erlog.erl new file mode 100644 index 0000000..a6de23d --- /dev/null +++ b/src/core/erlog.erl @@ -0,0 +1,224 @@ +%% Copyright (c) 2008-2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : erlog.erl +%% Author : Robert Virding +%% Purpose : Main interface to the Erlog interpreter. +%% +%% Structures - {Functor,arg1, Arg2,...} where Functor is an atom +%% Variables - {Name} where Name is an atom or integer +%% Lists - Erlang lists +%% Atomic - Erlang constants +%% +%% There is no problem with the representation of variables as Prolog +%% functors of arity 0 are atoms. This representation is much easier +%% to test for, and create new variables with than using funny atom +%% names like '$1' (yuch!), and we need LOTS of variables. + +-module(erlog). +-behaviour(gen_server). +-vsn('3.0'). + +-include("erlog.hrl"). +-include("erlog_core.hrl"). + +%% Interface to server. +-export([start_link/1, start_link/0, execute/2, select/2, execute/3, select/3]). + +%% Gen server callbacs. +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3]). + +execute(Worker, Command, undefined) -> execute(Worker, Command); +execute(Worker, Command, Timeout) -> gen_server:call(Worker, {execute, trim_command(Command)}, Timeout). + +execute(Worker, Command) -> gen_server:call(Worker, {execute, trim_command(Command)}). + +select(Worker, Command, undefined) -> select(Worker, Command); +select(Worker, Command, Timeout) -> gen_server:call(Worker, {select, trim_command(Command)}, Timeout). + +select(Worker, Command) -> gen_server:call(Worker, {select, trim_command(Command)}). + +-spec start_link() -> pid(). +start_link() -> + gen_server:start_link(?MODULE, [], []). + +%% Database is your callback module. Params will be send to it's new(Params) callback +-spec start_link(Params :: proplists:proplist()) -> pid(). +start_link(Params) -> + gen_server:start_link(?MODULE, Params, []). + +init(Params) -> % use custom database implementation + FileCon = init_consulter(Params), + DbState = init_database(Params), + LibsDir = proplists:get_value(libs_dir, Params, "../lib"), %default assumes erlog is run from ebin + UdbState1 = load_prolog_libraries(FileCon, LibsDir, DbState), + UdbState2 = load_external_libraries(Params, FileCon, UdbState1), + Debugger = init_debugger(Params), + EventMan = case proplists:get_value(event_h, Params) of %register handler, if any + undefined -> undefined; + {Module, Arguments} -> + {ok, E} = gen_event:start_link(), + gen_event:add_handler(E, Module, Arguments), + E + end, + {ok, #state{db_state = UdbState2, f_consulter = FileCon, e_man = EventMan, debugger = Debugger, libs_dir = LibsDir}}. + +handle_call({execute, Command}, _From, State) -> %running prolog code in normal mode + {Res, _} = Repl = case erlog_scan:tokens([], Command, 1) of + {done, Result, _Rest} -> run_command(Result, State); % command is finished, run. + {more, _} -> {{ok, more}, State} % unfinished command. Report it and do nothing. + end, + NewState = change_state(Repl), + {reply, Res, NewState}; +handle_call({select, Command}, _From, State) -> %in selection solutions mode + {Res, _} = Repl = preprocess_command({select, Command}, State), + NewState = change_state(Repl), % change state, depending on reply + {reply, Res, NewState}. + +handle_cast(halt, St = #state{e_man = undefined}) -> + {stop, normal, St}; +handle_cast(halt, St = #state{e_man = E}) -> + gen_event:stop(E), %stom all handlers and event man + {stop, normal, St}. + +handle_info(_, St) -> + {noreply, St}. + +terminate(_, _) -> + ok. + +code_change(_, _, St) -> {ok, St}. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== +%% @private +% change state, depending on reply +change_state({{_, select}, State}) -> State; +change_state({_, State}) -> State#state{state = normal}. + +%% @private +%% Configurates database with arguments, populates it and returns. +-spec init_database(Params :: proplists:proplist()) -> #db_state{}. +init_database(Params) -> + Database = proplists:get_value(database, Params, erlog_dict), %default database is dict module + Args = proplists:get_value(arguments, Params, []), + {ok, State} = Database:new(Args), %create db and return its state + D = dict:new(), %create memory cores + DBState = #db_state{stdlib = D, exlib = D, in_mem = D, database = Database, state = State}, + load_built_in(DBState). %populate memory cores + +%% @private +-spec init_consulter(Params :: proplists:proplist()) -> fun() | any(). +init_consulter(Params) -> + proplists:get_value(f_consulter, Params, erlog_io). %get consulter module from params or default + +init_debugger(Params) -> + proplists:get_value(debugger, Params, fun(_, _, _) -> ok end). + +%% @private +load_built_in(Database) -> + %Load basic interpreter predicates + lists:foldl(fun(Mod, UDBState) -> Mod:load(UDBState) end, Database, ?STDLIB). + +%% @private +-spec load_prolog_libraries(atom(), list(), #db_state{}) -> #db_state{}. +load_prolog_libraries(Fcon, LibsDir, DbState) -> + Autoload = Fcon:lookup(LibsDir ++ "/autoload"), + lists:foldl( + fun(Lib, UdbState) -> + {ok, UpdDbState} = erlog_file:load_library(Fcon, LibsDir ++ "/autoload/" ++ Lib, UdbState), + UpdDbState + end, DbState, Autoload). + +%% @private +load_external_libraries(Params, FileCon, DbState) -> + case proplists:get_value(libraries, Params) of + undefined -> DbState; + Libraries -> + lists:foldl( + fun(Mod, UDbState) when is_atom(Mod) -> %autoload native library + Mod:load(UDbState); + (PrologLib, UDbState) when is_list(PrologLib) -> %autoload external library + {ok, UpdDbState} = erlog_file:load_library(FileCon, PrologLib, UDbState), + UpdDbState + end, DbState, Libraries) + end. + +%% @private +%% Run scanned command +run_command(Command, State) -> + case erlog_parse:parse_prolog_term(Command) of + {ok, halt} -> + gen_server:cast(self(), halt), + {true, State}; + PrologCmd -> preprocess_command(PrologCmd, State) + end. + +%% @private +%% Preprocess command +preprocess_command({ok, Command}, State = #state{f_consulter = Consulter, db_state = DbState}) when is_list(Command) -> %TODO may be remove me? + case erlog_logic:reconsult_files(Command, DbState, Consulter) of + {ok, UpdDbState} -> + {true, State#state{db_state = UpdDbState}}; + {error, {L, Pm, Pe}} -> + {erlog_io:format_error([L, Pm:format_error(Pe)]), State}; + {Error, Message} when Error == error; Error == erlog_error -> + {erlog_io:format_error([Message]), State} + end; +preprocess_command({ok, Command}, State) -> + {Result, NewState} = process_command({prove, Command}, State), + {erlog_logic:shell_prove_result(Result), NewState}; +preprocess_command({error, {_, Em, E}}, State) -> {erlog_io:format_error([Em:format_error(E)]), State}; +preprocess_command({select, Value}, State) -> + {Next, NewState} = process_command(next, State), + {erlog_logic:select_bindings(Value, Next), NewState}. + +%% @private +%% Process command, modify state. Return {Result, NewState} +-spec process_command(tuple() | atom(), State :: #state{}) -> tuple(). +process_command({prove, Goal}, State) -> + prove_goal(Goal, State); +process_command(next, State = #state{state = normal}) -> % can't select solution, when not in select mode + {fail, State}; +process_command(next, State = #state{state = [Vs, Cps], db_state = DbState, f_consulter = Consulter, libs_dir = LD}) -> + case erlog_logic:prove_result(catch erlog_errors:fail(#param{choice = Cps, database = DbState, f_consulter = Consulter, libs_dir = LD}), Vs) of + {Atom, Res, Args, Udb} -> {{Atom, Res}, State#state{state = Args, db_state = Udb}}; + {fail, Db} -> {fail, State#state{db_state = Db}}; + Other -> {Other, State} + end; +process_command(halt, State) -> + gen_server:cast(self(), halt), + {ok, State}. + +%% @private +prove_goal(Goal0, State = #state{db_state = Db, f_consulter = Consulter, e_man = Event, debugger = Deb, libs_dir = LD}) -> + Vs = erlog_logic:vars_in(Goal0), + %% Goal may be a list of goals, ensure proper goal. + Goal1 = erlog_logic:unlistify(Goal0), + %% Must use 'catch' here as 'try' does not do last-call + %% optimisation. + case erlog_logic:prove_result(catch erlog_ec_core:prove_goal(Goal1, Db, Consulter, Event, Deb, LD), Vs) of + {succeed, Res, Args, UDbState} -> {{succeed, Res}, State#state{state = Args, db_state = UDbState}}; + {fail, Db} -> {fail, State#state{db_state = Db}}; + OtherRes -> {OtherRes, State} + end. + +%% @private +%% Adds "\r\n" to command. We need this, as erlog_scan reply more on commands without such ending +trim_command(Command) -> + case lists:suffix([13, 10], Command) of + true -> Command; + _ -> lists:append(Command, [13, 10]) + end. \ No newline at end of file diff --git a/src/core/erlog_errors.erl b/src/core/erlog_errors.erl new file mode 100644 index 0000000..9000d5e --- /dev/null +++ b/src/core/erlog_errors.erl @@ -0,0 +1,106 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 18. июн 2014 23:16 +%%%------------------------------------------------------------------- +-module(erlog_errors). +-author("tihon"). + +-include("erlog_core.hrl"). + +%% API +-export([type_error/3, instantiation_error/1, permission_error/3, + type_error/2, instantiation_error/0, erlog_error/2, erlog_error/1, fail/1]). + +%% Errors +%% To keep dialyzer quiet. +-spec type_error(_, _) -> no_return(). +-spec type_error(_, _, _) -> no_return(). +-spec instantiation_error() -> no_return(). +-spec instantiation_error(_) -> no_return(). +-spec permission_error(_, _, _) -> no_return(). +-spec erlog_error(_) -> no_return(). +-spec erlog_error(_, _) -> no_return(). + +type_error(Type, Value, Db) -> erlog_error({type_error, Type, Value}, Db). +type_error(Type, Value) -> erlog_error({type_error, Type, Value}). + +instantiation_error(Db) -> erlog_error(instantiation_error, Db). +instantiation_error() -> erlog_error(instantiation_error). + +permission_error(Op, Type, Value) -> + erlog_error({permission_error, Op, Type, Value}). + +erlog_error(E, Db) -> throw({erlog_error, E, Db}). %TODO remove DB!! +erlog_error(E) -> throw({erlog_error, E}). + +%% fail(ChoicePoints, Database) -> {fail,Database}. +%% cut(Label, Last, Next, ChoicePoints, Bindings, VarNum, Database) -> void. +%% +%% The functions which manipulate the choice point stack. fail +%% backtracks to next choicepoint skipping cut labels cut steps +%% backwards over choice points until matching cut. +fail(Param = #param{choice = [#cp{type = goal_clauses} = Cp | Cps]}) -> + fail_goal_clauses(Cp, Param#param{choice = Cps}); +fail(Param = #param{choice = [#cp{type = db_goal_clauses} = Cp | Cps]}) -> + erlog_db_logic:fail_goal_clauses(Cp, Param#param{choice = Cps}); +fail(Param = #param{choice = [#cp{type = Type} = Cp | Cps]}) when Type == disjunction; Type == if_then_else -> + fail_disjunction(Cp, Param#param{choice = Cps}); +fail(Param = #param{choice = [#cp{type = clause} = Cp | Cps]}) -> + fail_clause(Cp, Param#param{choice = Cps}); +fail(Param = #param{choice = [#cp{type = findall} = Cp | Cps]}) -> + fail_findall(Cp, Param#param{choice = Cps}); +fail(Param = #param{choice = [#cp{type = retract} = Cp | Cps]}) -> + fail_retract(Cp, Param#param{choice = Cps}); +fail(Param = #param{choice = [#cp{type = db_retract} = Cp | Cps]}) -> + erlog_db_logic:fail_retract(Cp, Param#param{choice = Cps}); +fail(Param = #param{choice = [#cp{type = current_predicate} = Cp | Cps]}) -> + fail_current_predicate(Cp, Param#param{choice = Cps}); +fail(Param = #param{choice = [#cp{type = ecall} = Cp | Cps]}) -> + fail_ecall(Cp, Param#param{choice = Cps}); +fail(#param{choice = [#cp{type = compiled, data = F} = Cp | Cps], database = Db}) -> + F(Cp, Cps, Db); %TODO test this +fail(Param = #param{choice = [#cut{} | Cps]}) -> + fail(Param#param{choice = Cps}); %Fail over cut points. +fail(#param{choice = [], database = Db}) -> {fail, Db}. + +%% @private +fail_disjunction(#cp{next = Next, bs = Bs, vn = Vn}, Param) -> + erlog_ec_core:prove_body(Param#param{goal = Next, bindings = Bs, var_num = Vn}). + +%% @private +fail_ecall(#cp{data = {Efun, Val}, next = Next, bs = Bs, vn = Vn}, Param) -> + erlog_ec_logic:prove_ecall(Efun, Val, Param#param{next_goal = Next, bindings = Bs, var_num = Vn}). + +%% @private +fail_clause(#cp{data = {Ch, Cb, _, Cursor}, next = Next, bs = Bs, vn = Vn}, Param = #param{database = Db}) -> %TODO remove unneeded Db in #cp + {{UCursor, Res}, UDb} = erlog_memory:next(Db, Cursor), + erlog_ec_unify:unify_clauses(Ch, Cb, Res, Param#param{next_goal = Next, bindings = Bs, var_num = Vn, cursor = UCursor, database = UDb}). + +%% @private +fail_retract(#cp{data = {Ch, Cb, {_, Cursor}}, next = Next, bs = Bs, vn = Vn}, Param = #param{database = Db}) -> %TODO remove unneeded Db in #cp + {{UCursor, Res}, UDb} = erlog_memory:next(Db, Cursor), + erlog_ec_logic:retract_clauses(Ch, Cb, Res, Param#param{next_goal = Next, bindings = Bs, var_num = Vn, cursor = UCursor, database = UDb}). + +%% @private +fail_current_predicate(#cp{data = {Pi, Fs}, next = Next, bs = Bs, vn = Vn}, Param) -> + erlog_ec_logic:prove_predicates(Pi, Fs, Param#param{next_goal = Next, bindings = Bs, var_num = Vn}). + +%% @private +fail_goal_clauses(#cp{data = {G, _, Cursor}, next = Next, bs = Bs, vn = Vn}, Param = #param{database = Db, debugger = Deb}) -> %TODO remove unneeded Db in #cp + {{UCursor, Res}, UDb} = erlog_memory:next(Db, Cursor), + Deb(fail, G, Bs), + erlog_ec_core:prove_goal_clauses(Res, Param#param{goal = G, next_goal = Next, bindings = Bs, var_num = Vn, cursor = UCursor, database = UDb}). + +fail_findall(#cp{next = Next, data = {Tag, Bag}, bs = Bs, vn = Vn0}, Param = #param{database = Db}) -> + Data = erlog_memory:raw_fetch(Db, Tag), + Udb = erlog_memory:raw_erase(Db, Tag), %Clear special entry + {Bs1, Vn1} = lists:mapfoldl( + fun(B0, V0) -> %Create proper instances + {B1, _, V1} = erlog_ec_term:term_instance(erlog_ec_support:dderef(B0, Bs), V0), + {B1, V1} + end, Vn0, Data), + erlog_ec_body:unify_prove_body(Bag, Bs1, Param#param{next_goal = Next, var_num = Vn1, database = Udb}). \ No newline at end of file diff --git a/src/core/erlog_file_consulter.erl b/src/core/erlog_file_consulter.erl new file mode 100644 index 0000000..389820b --- /dev/null +++ b/src/core/erlog_file_consulter.erl @@ -0,0 +1,16 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 25. Окт. 2014 0:22 +%%%------------------------------------------------------------------- +-module(erlog_file_consulter). +-author("tihon"). + +%% get list of files in directory +-callback lookup(Directory :: string()) -> Files :: list(). + +%% consult selected file +-callback load(FileLoc :: string()) -> {ok, [Term :: term()]} | {error, Error :: term()}. diff --git a/src/core/erlog_logic.erl b/src/core/erlog_logic.erl new file mode 100644 index 0000000..902dfa9 --- /dev/null +++ b/src/core/erlog_logic.erl @@ -0,0 +1,107 @@ +%% Copyright (c) 2008-2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : erlog_shell.erl +%% Author : Robert Virding +%% Purpose : Module with functions realisation of erlog module api + +-module(erlog_logic). + +-include("erlog_core.hrl"). + +-export([vars_in/1, is_legal_term/1, reconsult_files/3, select_bindings/2, shell_prove_result/1, prove_result/2, unlistify/1]). + +%% @private +unlistify([G | Gs]) -> {',', G, unlistify(Gs)}; +unlistify([]) -> true; +unlistify(G) -> G. %In case it wasn't a list. + +prove_result({succeed, Cps, Bs, _Vn, Db}, Vs) -> + {succeed, erlog_ec_support:dderef(Vs, Bs), [Vs, Cps], Db}; +prove_result({fail, Db}, _Vs) -> + {fail, Db}; +prove_result({erlog_error, Error, _Db1}, _Vs) -> + {error, Error}; +prove_result({erlog_error, Error}, _Vs) -> %No new database + {error, Error}; +prove_result({'EXIT', Error}, _Vs) -> + {'EXIT', Error}. + +-spec reconsult_files(list(), pid(), atom()) -> ok | tuple(). +reconsult_files(FileList, DbState, Consulter) when is_list(FileList) -> + catch lists:foldl( + fun(File, UDBState) -> + case erlog_file:reconsult(Consulter, File, UDBState) of + {ok, UpdDBState} -> UpdDBState; + {error, Error} -> throw({error, Error}) + end + end, DbState, FileList); +reconsult_files(Other, _Db, _Fun) -> {error, {type_error, list, Other}}. + +shell_prove_result({succeed, Vs}) -> show_bindings(Vs); +shell_prove_result(fail) -> false; +shell_prove_result({fail, _}) -> false; +shell_prove_result({error, Error}) -> erlog_io:format_error([Error]); +shell_prove_result({'EXIT', Error}) -> erlog_io:format_error("EXIT", [Error]). + +%% show_bindings(VarList, Pid) +%% Show the bindings and query user for next solution. +show_bindings([]) -> true; +show_bindings(Vs) -> %TODO where atoms are created? + Out = lists:foldr( + fun({Name, Val}, Acc) -> +%% [erlog_io:writeq1({'=', {Name}, Val}) | Acc] + [{Name, Val} | Acc] %TODO. Test, is this suitable for all variants? If so - writeq can be deleted. + end, [], Vs), %format reply + {{true, Out}, select}. + +select_bindings(Selection, Next) -> + case string:chr(Selection, $;) of + 0 -> true; + _ -> shell_prove_result(Next) + end. + +%% vars_in(Term) -> [{Name,Var}]. +%% Returns an ordered list of {VarName,Variable} pairs. +vars_in(Term) -> vars_in(Term, orddict:new()). + +vars_in({'_'}, Vs) -> Vs; %Never in! +vars_in({Name} = Var, Vs) -> orddict:store(Name, Var, Vs); +vars_in(Struct, Vs) when is_tuple(Struct) -> + vars_in_struct(Struct, 2, size(Struct), Vs); +vars_in([H | T], Vs) -> + vars_in(T, vars_in(H, Vs)); +vars_in(_, Vs) -> Vs. + +vars_in_struct(_Str, I, S, Vs) when I > S -> Vs; +vars_in_struct(Str, I, S, Vs) -> + vars_in_struct(Str, I + 1, S, vars_in(element(I, Str), Vs)). + +%% is_legal_term(Goal) -> true | false. +%% Test if a goal is a legal Erlog term. Basically just check if +%% tuples are used correctly as structures and variables. +is_legal_term({V}) -> is_atom(V); +is_legal_term([H | T]) -> + is_legal_term(H) andalso is_legal_term(T); +is_legal_term(T) when is_tuple(T) -> + if tuple_size(T) >= 2, is_atom(element(1, T)) -> + are_legal_args(T, 2, size(T)); %The right tuples. + true -> false + end; +is_legal_term(T) when ?IS_ATOMIC(T) -> true; %All constants, including [] +is_legal_term(_T) -> false. + +are_legal_args(_T, I, S) when I > S -> true; +are_legal_args(T, I, S) -> + is_legal_term(element(I, T)) andalso are_legal_args(T, I + 1, S). \ No newline at end of file diff --git a/src/core/erlog_parse.erl b/src/core/erlog_parse.erl new file mode 100644 index 0000000..54a70ee --- /dev/null +++ b/src/core/erlog_parse.erl @@ -0,0 +1,324 @@ +%% Copyright (c) 2008-2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : erlog_parse.erl +%% Author : Robert Virding +%% Purpose : Erlog parser +%% +%% Parses Erlog tokens into Erlog terms. Based on the Standard prolog +%% parser and directly coded from the parser description. To handle +%% back-tracking in the parser we use a continuation style using funs +%% where each fun handles one step of what follows. This allows +%% back-tracking. This may not be a specially efficient way of +%% parsing but it is simple and easy to derive from the +%%% description. No logical variables are necessary here. + +-module(erlog_parse). + +-export([term/1, term/2, format_error/1, parse_prolog_term/1]). +-export([prefix_op/1, infix_op/1, postfix_op/1]). + +-compile({nowarn_unused_function, [type/1, line/1, val/1]}). +%% -compile(export_all). + +term(Toks) -> term(Toks, 1). + +term(Toks, _) -> + case term(Toks, 1200, fun(Ts, T) -> all_read(Ts, T) end) of + {succeed, Term} -> {ok, Term}; + {fail, {Line, Error}} -> {error, {Line, ?MODULE, Error}} + end. + +all_read([{'.', _}], Term) -> {succeed, Term}; +all_read([{T, L} | _], _) -> syntax_error(L, {operator_expected, T}); +all_read([{_, L, V} | _], _) -> syntax_error(L, {operator_expected, V}); +all_read([], _) -> syntax_error(9999, premature_end). + +syntax_error(Line, Error) -> {fail, {Line, Error}}. +%% syntax_error(Line, Error) -> +%% io:fwrite("se: ~p\n", [{Line,Error}]), {fail,{Line,Error}}. + +format_error(premature_end) -> "premature end"; +format_error({operator_expected, T}) -> + io_lib:fwrite("operator expected before: ~w", [T]); +format_error({illegal, T}) -> + io_lib:fwrite("illegal token: ~w", [T]); +format_error(no_term) -> "missing term"; +format_error({op_priority, Op}) -> + io_lib:fwrite("operator priority clash: ~w", [Op]); +format_error({expected, T}) -> + io_lib:fwrite("~w or operator expected", [T]). + +%% term(Tokens, Precedence, Next) -> {succeed,Term} | {fail,Error}. + +term([{number, _, N} | Toks], Prec, Next) -> rest_term(Toks, N, 0, Prec, Next); +term([{string, _, S} | Toks], Prec, Next) -> rest_term(Toks, S, 0, Prec, Next); +term([{'(', _} | Toks], Prec, Next) -> + bracket_term(Toks, Prec, Next); +term([{' (', _} | Toks], Prec, Next) -> + bracket_term(Toks, Prec, Next); +term([{'{', L}, {'}', _} | Toks], Prec, Next) -> + term([{atom, L, '{}'} | Toks], Prec, Next); +term([{'{', _} | Toks0], Prec, Next) -> + term(Toks0, 1200, + fun(Toks1, Term) -> + expect(Toks1, '}', Term, + fun(Toks2, Term1) -> + rest_term(Toks2, {'{}', Term1}, 0, Prec, Next) + end) + end); +term([{'[', _}, {']', _} | Toks], Prec, Next) -> + rest_term(Toks, [], 0, Prec, Next); +term([{'[', _} | Toks0], Prec, Next) -> + term(Toks0, 999, + fun(Toks1, E) -> + list_elems(Toks1, [E], + fun(Toks2, List) -> + rest_term(Toks2, List, 0, Prec, Next) + end) + end); +term([{var, _, V} | Toks], Prec, Next) -> rest_term(Toks, {V}, 0, Prec, Next); +term([{atom, _, F}, {'(', _} | Toks0], Prec, Next) -> + %% Compound term in functional syntax. + term(Toks0, 999, + fun(Toks1, A) -> + arg_list(Toks1, [A], + fun(Toks2, Args) -> + %% Equivalence of '.'/2 and lists. + Term = case {F, Args} of + {'.', [H, T]} -> [H | T]; + _ -> list_to_tuple([F | Args]) + end, + rest_term(Toks2, Term, 0, Prec, Next) + end) + end); +term([{atom, L, Op} | Toks0], Prec, Next) -> + case prefix_op(Op) of + {yes, OpP, ArgP} when Prec >= OpP -> + case possible_right_operand(Toks0) of + true -> + %% First try as prefix op, then as atom. + Next1 = fun(Toks1, Arg) -> + rest_term(Toks1, {Op, Arg}, OpP, Prec, Next) + end, + cp([fun() -> term(Toks0, ArgP, Next1) end, + fun() -> rest_term(Toks0, Op, 0, Prec, Next) end]); + false -> rest_term(Toks0, Op, 0, Prec, Next) + end; + {yes, _, _} -> + syntax_error(L, {op_priority, Op}); + no -> rest_term(Toks0, Op, 0, Prec, Next) + end; +term([{T, L} | _], _, _) -> syntax_error(L, {illegal, T}); +term([{_, L, V} | _], _, _) -> syntax_error(L, {illegal, V}); +term([], _, _) -> syntax_error(9999, no_term). + +%% possible_right_operand(Tokens) -> true | false. +%% Test if there maybe a possible right operand. + +possible_right_operand([{')', _} | _]) -> false; +possible_right_operand([{'}', _} | _]) -> false; +possible_right_operand([{']', _} | _]) -> false; +possible_right_operand([{',', _} | _]) -> false; +possible_right_operand([{'|', _} | _]) -> false; +possible_right_operand(_) -> true. + +%% bracket_term(Tokens, Precedence, Next) -> +%% {succeed,Term} | {fail,Error}. + +bracket_term(Toks0, Prec, Next) -> + term(Toks0, 1200, + fun(Toks1, Term) -> + expect(Toks1, ')', Term, + fun(Toks2, Term1) -> + rest_term(Toks2, Term1, 0, Prec, Next) + end) + end). + +%% rest_term(Tokens, Term, LeftPrec, Precedence, Next) -> +%% {succeed,Term} | {fail,Error}. +%% Have a term to the left, test if operator follows or just go on. + +rest_term([{atom, L, Op} | Toks0], Term, Left, Prec, Next) -> + cp([fun() -> infix_term(Op, L, Toks0, Term, Left, Prec, Next) end, + fun() -> postfix_term(Op, L, Toks0, Term, Left, Prec, Next) end, + fun() -> Next([{atom, L, Op} | Toks0], Term) end]); +rest_term([{',', L} | Toks0], Term, Left, Prec, Next) -> + %% , is an operator as well as a separator. + if Prec >= 1000, Left < 1000 -> + term(Toks0, 1000, + fun(Toks1, RArg) -> + rest_term(Toks1, {',', Term, RArg}, 1000, Prec, Next) + end); + true -> Next([{',', L} | Toks0], Term) + end; +rest_term(Toks, Term, _, _, Next) -> + Next(Toks, Term). + +%% infix_term(Operator, Line, Tokens, Term, LeftPrec, Prec, Next) -> +%% {succeed,Term} | {fail,Error}. +%% Test if infix operator of correct priority, fail with +%% operator_expected if not an operator to have some error. + +infix_term(Op, L, Toks0, Term, Left, Prec, Next) -> + case infix_op(Op) of + {yes, LAP, OpP, RAP} when Prec >= OpP, Left =< LAP -> + term(Toks0, RAP, + fun(Toks1, Arg2) -> + rest_term(Toks1, {Op, Term, Arg2}, OpP, Prec, Next) + end); + {yes, _, _, _} -> syntax_error(L, {op_priority, Op}); + no -> fail + end. + +%% postfix_term(Operator, Line, Tokens, Term, LeftPrec, Prec, Next) -> +%% {succeed,Term} | {fail,Error}. +%% Test if postfix operator of correct priority, fail with +%% operator_expected if not an operator to have some error. + +postfix_term(Op, L, Toks0, Term, Left, Prec, Next) -> + case postfix_op(Op) of + {yes, ArgP, OpP} when Prec >= OpP, Left =< ArgP -> + rest_term(Toks0, {Op, Term}, OpP, Prec, Next); + {yes, _, _} -> syntax_error(L, {op_priority, Op}); + no -> fail + end. + +%% list_elems(Tokens, RevElems, Next) -> +%% {succeed,Term} | {fail,Error}. + +list_elems([{',', _} | Toks0], REs, Next) -> + term(Toks0, 999, + fun(Toks1, E) -> + list_elems(Toks1, [E | REs], Next) + end); +list_elems([{'|', _} | Toks0], REs, Next) -> + term(Toks0, 999, + fun(Toks1, E) -> + expect(Toks1, ']', lists:reverse(REs, E), Next) + end); +list_elems(Toks, REs, Next) -> + expect(Toks, ']', lists:reverse(REs), Next). + +%% arg_list(Tokens, RevArgs, Next) -> {succeed,Term} | {fail,Error}. + +arg_list([{',', _} | Toks0], RAs, Next) -> + term(Toks0, 999, + fun(Toks1, Arg) -> + arg_list(Toks1, [Arg | RAs], Next) + end); +arg_list(Toks, RAs, Next) -> + expect(Toks, ')', lists:reverse(RAs), Next). + +%% expect(Tokens, TokenType, Term, Next) -> {succeed,Term} | {fail,Error}. + +expect([T | Toks], Tok, Term, Next) -> + case type(T) of + Tok -> Next(Toks, Term); + _ -> syntax_error(line(T), {expected, Tok}) + end; +expect([], Tok, _, _) -> syntax_error(9999, {expected, Tok}). + +%% cp(Choices) -> {succeed,Term} | {fail,_} | fail. +%% Special choice point handler for parser. If all clauses fail then +%% fail with first fail value, this usually gives better error report. + +cp([C | Cs]) -> + case C() of + {succeed, Res} -> {succeed, Res}; + {fail, _} = Fail -> cp(Cs, Fail); %Try rest with first fail + fail -> cp(Cs) %Stay till we get reason + end. + +cp([C | Cs], Fail) -> + case C() of + {succeed, Res} -> {succeed, Res}; + {fail, _} -> cp(Cs, Fail); %Drop this fail, use first + fail -> cp(Cs, Fail) + end; +cp([], Fail) -> Fail. + +%% type(Tok) -> Line. +%% line(Tok) -> Line. +%% val(Tok) -> Value. + +type(Tok) -> element(1, Tok). +line(Tok) -> element(2, Tok). +val(Tok) -> element(3, Tok). + +%% prefix_op(Op) -> {yes,Prec,ArgPrec} | no. + +prefix_op('?-') -> {yes, 1200, 1199}; %fx 1200 +prefix_op(':-') -> {yes, 1200, 1199}; %fx 1200 +prefix_op('\\+') -> {yes, 900, 900}; %fy 900 +prefix_op('+') -> {yes, 200, 200}; %fy 200 +prefix_op('-') -> {yes, 200, 200}; %fy 200 +prefix_op('\\') -> {yes, 200, 200}; %fy 200 +prefix_op(_Op) -> no. %The rest + +%% postfix_op(Op) -> {yes,ArgPrec,Prec} | no. + +postfix_op('+') -> {yes, 500, 500}; +postfix_op('*') -> {yes, 400, 400}; +postfix_op(_Op) -> no. + +%% infix_op(Op) -> {yes,LeftArgPrec,Prec,RightArgPrec} | no. + +infix_op(':-') -> {yes, 1199, 1200, 1199}; %xfx 1200 +infix_op('-->') -> {yes, 1199, 1200, 1199}; %xfx 1200 +infix_op(';') -> {yes, 1099, 1100, 1100}; %xfy 1100 +infix_op('->') -> {yes, 1049, 1050, 1050}; %xfy 1050 +infix_op(',') -> {yes, 999, 1000, 1000}; %xfy 1000 +infix_op('=') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('\\=') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('\\==') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('==') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('@<') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('@=<') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('@>') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('@>=') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('=..') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('is') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('=:=') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('=\\=') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('<') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('=<') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('>') -> {yes, 699, 700, 699}; %xfx 700 +infix_op('>=') -> {yes, 699, 700, 699}; %xfx 700 +infix_op(':') -> {yes, 599, 600, 600}; %xfy 600 +infix_op('+') -> {yes, 500, 500, 499}; %yfx 500 +infix_op('-') -> {yes, 500, 500, 499}; %yfx 500 +infix_op('/\\') -> {yes, 500, 500, 499}; %yfx 500 +infix_op('\\/') -> {yes, 500, 500, 499}; %yfx 500 +infix_op('*') -> {yes, 400, 400, 399}; %yfx 400 +infix_op('/') -> {yes, 400, 400, 399}; %yfx 400 +infix_op('//') -> {yes, 400, 400, 399}; %yfx 400 +infix_op('rem') -> {yes, 400, 400, 399}; %yfx 400 +infix_op('mod') -> {yes, 400, 400, 399}; %yfx 400 +infix_op('<<') -> {yes, 400, 400, 399}; %yfx 400 +infix_op('>>') -> {yes, 400, 400, 399}; %yfx 400 +infix_op('**') -> {yes, 199, 200, 199}; %xfx 200 +infix_op('^') -> {yes, 199, 200, 200}; %xfy 200 +infix_op(_Op) -> no. + +parse_prolog_term({ok, Ts}) -> parse(Ts); +parse_prolog_term({ok, Ts, _}) -> parse(Ts); +parse_prolog_term({error, Se, _}) -> {error, Se}; +parse_prolog_term({eof, _}) -> {ok, end_of_file}. %Prolog does this + +parse(Ts) -> + case erlog_parse:term(Ts) of + {ok, T} -> {ok, T}; + {error, Pe} -> {error, Pe} + end. \ No newline at end of file diff --git a/src/erlog_scan.xrl b/src/core/erlog_scan.xrl similarity index 100% rename from src/erlog_scan.xrl rename to src/core/erlog_scan.xrl diff --git a/src/core/erlog_simple_printer.erl b/src/core/erlog_simple_printer.erl new file mode 100644 index 0000000..34a5c5c --- /dev/null +++ b/src/core/erlog_simple_printer.erl @@ -0,0 +1,160 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 10. Июль 2014 13:26 +%%%------------------------------------------------------------------- +-module(erlog_simple_printer). +-author("tihon"). + +-behaviour(gen_event). + +%% API +-export([start_link/0, + add_handler/0]). + +%% gen_event callbacks +-export([init/1, + handle_event/2, + handle_call/2, + handle_info/2, + terminate/2, + code_change/3]). + +-define(SERVER, ?MODULE). + +-record(state, {}). + +%%%=================================================================== +%%% gen_event callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @doc +%% Creates an event manager +%% +%% @end +%%-------------------------------------------------------------------- +-spec(start_link() -> {ok, pid()} | {error, {already_started, pid()}}). +start_link() -> + gen_event:start_link({local, ?SERVER}). + +%%-------------------------------------------------------------------- +%% @doc +%% Adds an event handler +%% +%% @end +%%-------------------------------------------------------------------- +-spec(add_handler() -> ok | {'EXIT', Reason :: term()} | term()). +add_handler() -> + gen_event:add_handler(?SERVER, ?MODULE, []). + +%%%=================================================================== +%%% gen_event callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever a new event handler is added to an event manager, +%% this function is called to initialize the event handler. +%% +%% @end +%%-------------------------------------------------------------------- +-spec(init(InitArgs :: term()) -> + {ok, State :: #state{}} | + {ok, State :: #state{}, hibernate} | + {error, Reason :: term()}). +init([]) -> + {ok, #state{}}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever an event manager receives an event sent using +%% gen_event:notify/2 or gen_event:sync_notify/2, this function is +%% called for each installed event handler to handle the event. +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_event(Event :: term(), State :: #state{}) -> + {ok, NewState :: #state{}} | + {ok, NewState :: #state{}, hibernate} | + {swap_handler, Args1 :: term(), NewState :: #state{}, + Handler2 :: (atom() | {atom(), Id :: term()}), Args2 :: term()} | + remove_handler). +handle_event(Event, State) -> + io:format("~p: ~p~n", [?MODULE, Event]), + {ok, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever an event manager receives a request sent using +%% gen_event:call/3,4, this function is called for the specified +%% event handler to handle the request. +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_call(Request :: term(), State :: #state{}) -> + {ok, Reply :: term(), NewState :: #state{}} | + {ok, Reply :: term(), NewState :: #state{}, hibernate} | + {swap_handler, Reply :: term(), Args1 :: term(), NewState :: #state{}, + Handler2 :: (atom() | {atom(), Id :: term()}), Args2 :: term()} | + {remove_handler, Reply :: term()}). +handle_call(_Request, State) -> + Reply = ok, + {ok, Reply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% This function is called for each installed event handler when +%% an event manager receives any other message than an event or a +%% synchronous request (or a system message). +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_info(Info :: term(), State :: #state{}) -> + {ok, NewState :: #state{}} | + {ok, NewState :: #state{}, hibernate} | + {swap_handler, Args1 :: term(), NewState :: #state{}, + Handler2 :: (atom() | {atom(), Id :: term()}), Args2 :: term()} | + remove_handler). +handle_info(_Info, State) -> + {ok, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever an event handler is deleted from an event manager, this +%% function is called. It should be the opposite of Module:init/1 and +%% do any necessary cleaning up. +%% +%% @spec terminate(Reason, State) -> void() +%% @end +%%-------------------------------------------------------------------- +-spec(terminate(Args :: (term() | {stop, Reason :: term()} | stop | +remove_handler | {error, {'EXIT', Reason :: term()}} | +{error, term()}), State :: term()) -> term()). +terminate(_Arg, _State) -> + ok. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Convert process state when code is changed +%% +%% @end +%%-------------------------------------------------------------------- +-spec(code_change(OldVsn :: term() | {down, term()}, State :: #state{}, + Extra :: term()) -> + {ok, NewState :: #state{}}). +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== diff --git a/src/core/logic/erlog_ec_body.erl b/src/core/logic/erlog_ec_body.erl new file mode 100644 index 0000000..e4f2070 --- /dev/null +++ b/src/core/logic/erlog_ec_body.erl @@ -0,0 +1,150 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 15. Июль 2014 16:06 +%%%------------------------------------------------------------------- +-module(erlog_ec_body). +-author("tihon"). + +-include("erlog_core.hrl"). + +%% API +-export([body_instance/5, unify_prove_body/3, unify_prove_body/5, body_term/3, well_form_body/4, well_form_body/3]). + +%% unify_prove_body(Term1, Term2, Next, ChoicePoints, Bindings, VarNum, Database) -> +%% void. +%% Unify Term1 = Term2, on success prove body Next else fail. +unify_prove_body(T1, T2, Params = #param{next_goal = Next, bindings = Bs0}) -> + case erlog_ec_unify:unify(T1, T2, Bs0) of + {succeed, Bs1} -> erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}); + fail -> erlog_errors:fail(Params) + end. + +%% unify_prove_body(A1, B1, A2, B2, Next, ChoicePoints, Bindings, VarNum, Database) -> +%% void. +%% Unify A1 = B1, A2 = B2, on success prove body Next else fail. +unify_prove_body(A1, B1, A2, B2, Params = #param{bindings = Bs0}) -> + case erlog_ec_unify:unify(A1, B1, Bs0) of + {succeed, Bs1} -> unify_prove_body(A2, B2, Params#param{bindings = Bs1}); + fail -> erlog_errors:fail(Params) + end. + +%% body_instance(Body, Tail, Repls, VarNum, Label) -> +%% {Body,NewRepls,NewVarNum}. +%% Generate a copy of a body in a form ready to be interpreted. No +%% bindings from original variables to new variables. It can handle +%% replacing integer variables with overlapping integer ranges. Don't +%% check Term as it should already be checked. Use term_instance to +%% handle goals. N.B. We have to be VERY careful never to go into the +%% original tail as this will cause havoc. +body_instance([{{cut} = Cut, _, Last} | Gs0], Tail, Rs0, Vn0, Label) -> + {Gs1, Rs1, Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), + {[{Cut, Label, Last} | Gs1], Rs1, Vn1}; +body_instance([{{disj} = Disj, L0, R0} | Gs0], Tail, Rs0, Vn0, Label) -> + {Gs1, Rs1, Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), + %% Append Gs1 directly to L and R. + {L1, Rs2, Vn2} = body_instance(L0, Gs1, Rs1, Vn1, Label), + {R1, Rs3, Vn3} = body_instance(R0, Gs1, Rs2, Vn2, Label), + {[{Disj, R1} | L1], Rs3, Vn3}; +body_instance([{{if_then} = IT, C0, T0, _} | Gs0], Tail, Rs0, Vn0, Label) -> + {Gs1, Rs1, Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), + {T1, Rs2, Vn2} = body_instance(T0, Gs1, Rs1, Vn1, Label), + {C1, Rs3, Vn3} = body_instance(C0, [{{cut}, Label, true} | T1], Rs2, Vn2, Label), + %% Append Gs1 directly to T1 to C1. + {[{IT, Label} | C1], Rs3, Vn3}; +body_instance([{{if_then_else} = ITE, C0, T0, E0, _} | Gs0], Tail, Rs0, Vn0, Label) -> + {Gs1, Rs1, Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), + {T1, Rs2, Vn2} = body_instance(T0, Gs1, Rs1, Vn1, Label), + {C1, Rs3, Vn3} = body_instance(C0, [{{cut}, Label, true} | T1], Rs2, Vn2, Label), + {E1, Rs4, Vn4} = body_instance(E0, Gs1, Rs3, Vn3, Label), + {[{ITE, E1, Label} | C1], Rs4, Vn4}; +body_instance([{{once} = Once, G0, _} | Gs0], Tail, Rs0, Vn0, Label) -> + {Gs1, Rs1, Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), + {G1, Rs2, Vn2} = body_instance(G0, [{{cut}, Label, true} | Gs1], Rs1, Vn1, Label), + {[{Once, Label} | G1], Rs2, Vn2}; +body_instance([G0 | Gs0], Tail, Rs0, Vn0, Label) -> + {Gs1, Rs1, Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), + {G1, Rs2, Vn2} = erlog_ec_term:term_instance(G0, Rs1, Vn1), + {[G1 | Gs1], Rs2, Vn2}; +body_instance([], Tail, Rs, Vn, _Label) -> {Tail, Rs, Vn}. + +%% well_form_body(Body, HasCutAfter, CutLabel) -> {Body,HasCut}. +%% well_form_body(Body, Tail, HasCutAfter, CutLabel) -> {Body,HasCut}. +%% Check that Body is well-formed, flatten conjunctions, fix cuts and +%% add explicit call to top-level variables. +well_form_body(Body, Cut, Label) -> well_form_body(Body, [], Cut, Label). + +well_form_body({',', L, R}, Tail0, Cut0, Label) -> + {Tail1, Cut1} = well_form_body(R, Tail0, Cut0, Label), + well_form_body(L, Tail1, Cut1, Label); +well_form_body({';', {'->', C0, T0}, E0}, Tail, Cut0, Label) -> + {T1, Tc} = well_form_body(T0, Cut0, Label), + {E1, Ec} = well_form_body(E0, Cut0, Label), + %% N.B. an extra cut will be added at run-time! + {C1, _} = well_form_body(C0, true, Label), + {[{{if_then_else}, C1, T1, E1, Label} | Tail], Tc or Ec}; +well_form_body({';', L0, R0}, Tail, Cut0, Label) -> + {L1, Lc} = well_form_body(L0, Cut0, Label), + {R1, Rc} = well_form_body(R0, Cut0, Label), + {[{{disj}, L1, R1} | Tail], Lc or Rc}; +well_form_body({'->', C0, T0}, Tail, Cut0, Label) -> + {T1, Cut1} = well_form_body(T0, Cut0, Label), + %% N.B. an extra cut will be added at run-time! + {C1, _} = well_form_body(C0, true, Label), + {[{{if_then}, C1, T1, Label} | Tail], Cut1}; +well_form_body({once, G}, Tail, Cut, Label) -> + %% N.B. an extra cut is added at run-time! + {G1, _} = well_form_body(G, true, Label), + {[{{once}, G1, Label} | Tail], Cut}; +well_form_body({V}, Tail, Cut, _Label) -> + {[{call, {V}} | Tail], Cut}; +well_form_body(true, Tail, Cut, _Label) -> {Tail, Cut}; %No-op +well_form_body(fail, _Tail, _Cut, _Label) -> {[fail], false}; %No further +well_form_body('!', Tail, Cut, Label) -> + {[{{cut}, Label, not Cut} | Tail], true}; +well_form_body(Goal, Tail, Cut, _Label) -> + erlog_ec_support:functor(Goal), %Check goal + {[Goal | Tail], Cut}. + +%% body_term(Body, Repls, VarNum) -> {Term,NewRepls,NewVarNum}. +%% Generate a copy of a body as a term with new, fresh unused +%% variables. No bindings from original variables to new +%% variables. It can handle replacing integer variables with +%% overlapping integer ranges. Don't check Term as it should already +%% be checked. Use orddict as there will seldom be many variables and +%% it it fast to setup. +body_term([{{cut}, _, _} | Gs0], Rs0, Vn0) -> + {Gs1, Rs1, Vn1} = body_term(Gs0, Rs0, Vn0), + {body_conj('!', Gs1), Rs1, Vn1}; +body_term([{{disj}, L0, R0} | Gs0], Rs0, Vn0) -> + {Gs1, Rs1, Vn1} = body_term(Gs0, Rs0, Vn0), + {L1, Rs2, Vn2} = body_term(L0, Rs1, Vn1), + {R1, Rs3, Vn3} = body_term(R0, Rs2, Vn2), + {body_conj({';', L1, R1}, Gs1), Rs3, Vn3}; +body_term([{{if_then}, C0, T0, _} | Gs0], Rs0, Vn0) -> + {Gs1, Rs1, Vn1} = body_term(Gs0, Rs0, Vn0), + {C1, Rs2, Vn2} = body_term(C0, Rs1, Vn1), + {T1, Rs3, Vn3} = body_term(T0, Rs2, Vn2), + {body_conj({'->', C1, T1}, Gs1), Rs3, Vn3}; +body_term([{{if_then_else}, C0, T0, E0, _} | Gs0], Rs0, Vn0) -> + {Gs1, Rs1, Vn1} = body_term(Gs0, Rs0, Vn0), + {C1, Rs2, Vn2} = body_term(C0, Rs1, Vn1), + {T1, Rs3, Vn3} = body_term(T0, Rs2, Vn2), + {E1, Rs4, Vn4} = body_term(E0, Rs3, Vn3), + {body_conj({';', {'->', C1, T1}, E1}, Gs1), Rs4, Vn4}; +body_term([{{once}, G0, _} | Gs0], Rs0, Vn0) -> + {Gs1, Rs1, Vn1} = body_term(Gs0, Rs0, Vn0), + {G1, Rs2, Vn2} = body_term(G0, Rs1, Vn1), + {body_conj({once, G1}, Gs1), Rs2, Vn2}; +body_term([G0 | Gs0], Rs0, Vn0) -> + {Gs1, Rs1, Vn1} = body_term(Gs0, Rs0, Vn0), + {G1, Rs2, Vn2} = erlog_ec_term:term_instance(G0, Rs1, Vn1), + {body_conj(G1, Gs1), Rs2, Vn2}; +body_term([], Rs, Vn) -> {true, Rs, Vn}. + + +body_conj(L, true) -> L; +body_conj(L, R) -> {',', L, R}. \ No newline at end of file diff --git a/src/core/logic/erlog_ec_core.erl b/src/core/logic/erlog_ec_core.erl new file mode 100644 index 0000000..f1d4499 --- /dev/null +++ b/src/core/logic/erlog_ec_core.erl @@ -0,0 +1,123 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 12. Авг. 2014 16:47 +%%%------------------------------------------------------------------- +-module(erlog_ec_core). +-author("tihon"). + +-include("erlog_core.hrl"). + +%% API +-export([prove_body/1, prove_goal/1, prove_goal/6, prove_goal_clauses/2, run_n_close/2, prove_goal_clause/2]). + +%% This is the main entry point into the interpreter. Check that +%% everything is consistent then prove the goal as a call. +-spec prove_goal(Goal0 :: term(), Db :: pid(), Consuter :: atom(), Event :: pid(), Deb :: fun(), LibsDir :: string()) -> term(). +prove_goal(Goal0, Db, Consulter, Event, Deb, LibsDir) -> + %% Check term and build new instance of term with bindings. + {Goal1, Bs, Vn} = erlog_ec_logic:initial_goal(Goal0), + Params = #param{goal = [{call, Goal1}], choice = [], bindings = Bs, var_num = Vn, + event_man = Event, database = Db, f_consulter = Consulter, debugger = Deb, libs_dir = LibsDir}, + erlog_ec_core:prove_body(Params). + +%% prove_body(Body, ChoicePoints, Bindings, VarNum, Database) -> +%% {succeed,ChoicePoints,NewBindings,NewVarNum,NewDatabase}. +%% Prove the goals in a body. Remove the first goal and try to prove +%% it. Return when there are no more goals. This is how proving a +%% goal/body succeeds. +prove_body(Params = #param{goal = [G | Gs], debugger = Deb, bindings = Bs}) -> + Deb(ok, G, Bs), + prove_goal(Params#param{goal = G, next_goal = Gs}); +prove_body(#param{goal = [], choice = Cps, bindings = Bs, var_num = Vn, database = Db}) -> + {succeed, Cps, Bs, Vn, Db}. %No more body + +%% Prove support first. Then find in database. +prove_goal(Param = #param{goal = {{once}, Label}, next_goal = Next, choice = Cps}) -> + %% We effetively implement once(G) with ( G, ! ) but cuts in + %% G are local to G. + %% There is no ( G, ! ) here, it has already been prepended to Next. + Cut = #cut{label = Label}, + prove_body(Param#param{goal = Next, choice = [Cut | Cps]}); +prove_goal(Param = #param{goal = {'??', Next}, bindings = Bs, debugger = Deb}) -> %debug stop point + Deb(stop, erlog_ec_support:dderef(Next, Bs), Bs), + prove_goal(Param#param{goal = Next}); +prove_goal(Param = #param{goal = {{if_then_else}, Else, Label}, next_goal = Next, choice = Cps, bindings = Bs, var_num = Vn}) -> + %% Need to push a choicepoint to fail back to inside Cond and a cut + %% to cut back to before Then when Cond succeeds. #cp{type=if_then_else} + %% functions as both as is always removed whatever the outcome. + %% There is no ( C, !, T ) here, it has already been prepended to Next. + Cp = #cp{type = if_then_else, label = Label, next = Else, bs = Bs, vn = Vn}, + %%io:fwrite("PG(->;): ~p\n", [{Next,Else,[Cp|Cps]}]), + prove_body(Param#param{goal = Next, choice = [Cp | Cps]}); +prove_goal(Param = #param{goal = {{if_then}, Label}, next_goal = Next, choice = Cps}) -> + %% We effetively implement ( C -> T ) with ( C, !, T ) but cuts in + %% C are local to C. + %% There is no ( C, !, T ) here, it has already been prepended to Next. + %%io:fwrite("PG(->): ~p\n", [{Next}]), + Cut = #cut{label = Label}, + prove_body(Param#param{goal = Next, choice = [Cut | Cps]}); +prove_goal(Param = #param{goal = {{cut}, Label, Last}}) -> + %% Cut succeeds and trims back to cut ancestor. + erlog_ec_support:cut(Label, Last, Param); +prove_goal(Param = #param{goal = {{disj}, R}, next_goal = Next, choice = Cps, bindings = Bs, var_num = Vn}) -> + %% There is no L here, it has already been prepended to Next. + Cp = #cp{type = disjunction, next = R, bs = Bs, vn = Vn}, + prove_body(Param#param{goal = Next, choice = [Cp | Cps]}); +prove_goal(Param = #param{goal = G, database = Db}) -> + case catch erlog_memory:get_procedure(Db, G) of + {{cursor, Cursor, result, Result}, UDB} -> + Fun = fun(Params) -> check_result(Result, Params) end, + run_n_close(Fun, Param#param{cursor = Cursor, database = UDB}); + {Result, UDB} -> check_result(Result, Param#param{database = UDB}) + end. + +%% prove_goal_clauses(Goal, Clauses, Next, ChoicePoints, Bindings, VarNum, Database) -> +%% void. +%% Try to prove Goal using Clauses which all have the same functor. +prove_goal_clauses([], Params) -> %end of checking clauses + erlog_errors:fail(Params); +prove_goal_clauses([C], Params = #param{choice = Cps, var_num = Vn}) -> %for clauses with body + %% Must be smart here and test whether we need to add a cut point. + %% C has the structure {Tag,Head,{Body,BodyHasCut}}. + case element(2, element(3, C)) of + true -> + Cut = #cut{label = Vn}, + prove_goal_clause(C, Params#param{choice = [Cut | Cps]}); + false -> + prove_goal_clause(C, Params) + end; +prove_goal_clauses(C, Params = #param{goal = G, next_goal = Next, var_num = Vn, bindings = Bs, choice = Cps, database = Db, cursor = Cursor}) -> + Cp = #cp{type = goal_clauses, label = Vn, data = {G, Db, Cursor}, next = Next, bs = Bs, vn = Vn}, + prove_goal_clause(C, Params#param{choice = [Cp | Cps]}). + +%% Run function and close cursor after that. +-spec run_n_close(Fun :: fun(), #param{}) -> any(). +run_n_close(Fun, Params = #param{database = Db, cursor = Cursor}) -> + try + Fun(Params) + after + erlog_memory:close(Db, Cursor) + end. + +prove_goal_clause([], Param) -> erlog_errors:fail(Param); +prove_goal_clause([L], Param) -> prove_goal_clause(L, Param); +prove_goal_clause({_Tag, H0, {B0, _}}, Param = #param{goal = G, next_goal = Next, bindings = Bs0, var_num = Vn0}) -> + Label = Vn0, + case erlog_ec_unify:unify_head(G, H0, Bs0, Vn0 + 1) of + {succeed, Rs0, Bs1, Vn1} -> + {B1, _Rs2, Vn2} = erlog_ec_body:body_instance(B0, Next, Rs0, Vn1, Label), + erlog_ec_core:prove_body(Param#param{goal = B1, bindings = Bs1, var_num = Vn2}); + fail -> erlog_errors:fail(Param) + end. + + +%% @private +check_result({built_in, Mod}, Param) -> Mod:prove_goal(Param); +check_result({code, {Mod, Func}}, Param) -> Mod:Func(Param); +check_result({clauses, Cs}, Param) -> prove_goal_clauses(Cs, Param); +check_result(undefined, Param) -> erlog_errors:fail(Param); +check_result({erlog_error, E}, #param{database = Db}) -> erlog_errors:erlog_error(E, Db). \ No newline at end of file diff --git a/src/core/logic/erlog_ec_support.erl b/src/core/logic/erlog_ec_support.erl new file mode 100644 index 0000000..a1e548a --- /dev/null +++ b/src/core/logic/erlog_ec_support.erl @@ -0,0 +1,200 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 15. Июль 2014 16:09 +%%%------------------------------------------------------------------- +-module(erlog_ec_support). +-author("tihon"). + +-include("erlog_core.hrl"). + +%% API +-export([new_bindings/0, get_binding/2, add_binding/3, + functor/1, cut/3, collect_alternatives/3, + update_result/4, update_vars/4, deref/2, dderef_list/2, + make_vars/2, pred_ind/1, deref_list/2, dderef/2, index_of/2, index_of/3, write/2, is_bound/1, try_add/3, check_var/2, get_vars/2]). + +%% deref(Term, Bindings) -> Term. +%% Dereference a variable, else just return the term. +deref({V} = T0, Bs) -> + case ?BIND:find(V, Bs) of + {ok, T1} -> deref(T1, Bs); + error -> T0 + end; +deref(T, _) -> T. %Not a variable, return it. + +%% deref_list(List, Bindings) -> List. +%% Dereference the top-level checking that it is a list. +deref_list([], _) -> []; %It already is a list +deref_list([_ | _] = L, _) -> L; +deref_list({V}, Bs) -> + case dict:find(V, Bs) of + {ok, L} -> deref_list(L, Bs); + error -> erlog_errors:instantiation_error() + end; +deref_list(Other, _) -> erlog_errors:type_error(list, Other). + +%% dderef(Term, Bindings) -> Term. +%% Do a deep dereference. Completely dereference all the variables +%% occuring in a term, even those occuring in a variables value. +dderef(A, _) when ?IS_CONSTANT(A) -> A; +dderef([], _) -> []; +dderef([H0 | T0], Bs) -> + [dderef(H0, Bs) | dderef(T0, Bs)]; +dderef({V} = Var, Bs) -> + case ?BIND:find(V, Bs) of + {ok, T} -> dderef(T, Bs); + error -> Var + end; +dderef(T, Bs) when is_tuple(T) -> + Es0 = tuple_to_list(T), + Es1 = dderef(Es0, Bs), + list_to_tuple(Es1). + +%% dderef_list(List, Bindings) -> List. +%% Dereference all variables to any depth but check that the +%% top-level is a list. +dderef_list([], _Bs) -> []; +dderef_list([H | T], Bs) -> + [dderef(H, Bs) | dderef_list(T, Bs)]; +dderef_list({V}, Bs) -> + case ?BIND:find(V, Bs) of + {ok, L} -> dderef_list(L, Bs); + error -> erlog_errors:instantiation_error() + end; +dderef_list(Other, _Bs) -> erlog_errors:type_error(list, Other). + +%% detects, whether variable is bound or not +-spec is_bound(term()) -> boolean(). +is_bound({N}) when is_integer(N) -> false; +is_bound(_) -> true. + +%% takes unbound vars from goal and return it +-spec get_vars(tuple(), dict:dict()) -> list(). +get_vars(Goal, Bs) -> + Bound = dderef(Goal, Bs), + lists:flatten(get_var(Bound, [])). + +%% make_vars(Count, VarNum) -> [Var]. +%% Make a list of new variables starting at VarNum. +make_vars(0, _) -> []; +make_vars(I, Vn) -> + [{Vn} | make_vars(I - 1, Vn + 1)]. + +%% functor(Goal) -> {Name,Arity}. +functor(T) when ?IS_FUNCTOR(T) -> + {element(1, T), tuple_size(T) - 1}; +functor(T) when is_atom(T) -> {T, 0}; +functor(T) -> erlog_errors:type_error(callable, T). + +%% Checks - if var is normal, or binded, or < 0 (if int). Returns var's value. +check_var({'-', Var}, Bs) -> + case check_var(Var, Bs) of + Res when is_number(Res) -> -1 * Res; + Res -> Res + end; +check_var({Var}, Bs) -> check_var(erlog_ec_support:deref({Var}, Bs), Bs); +check_var(Var, _) -> Var. + +pred_ind({N, A}) -> {'/', N, A}. + +%% pred_ind(N, A) -> {'/',N,A}. + +%% Bindings +%% Bindings are kept in a dict where the key is the variable name. +new_bindings() -> ?BIND:new(). + +%% Add bindings if acc is not bound. If it is bound - match result. +try_add(Var, Res, Bs) -> + Value = deref(Res, Bs), + case is_bound(Value) of + false -> add_binding(Res, Var, Bs); %not bound - just add var + true -> + case Value of %is bound. Fail if not the same + Var -> Bs; + _ -> error + end + end. + +add_binding({V}, Val, Bs0) -> + ?BIND:store(V, Val, Bs0). + +get_binding({V}, Bs) -> + ?BIND:find(V, Bs). + +collect_alternatives(Goal, FunList, Predicates) -> + Element = index_of(Goal, FunList) - 1, + lists:foldr( + fun({_, Pred, _}, Dict) -> + [_ | ParamList] = tuple_to_list(Pred), + Keys = remove_nth(ParamList, Element), + dict:append(Keys, lists:nth(Element, ParamList), Dict) + end, dict:new(), Predicates). + +update_result(Key, ResultDict, Res, Bs0) -> + case dict:find(Key, ResultDict) of + {ok, Value} -> add_binding(Res, Value, Bs0); + error -> Bs0 + end. + +update_vars(Goal, FunList, Key, Bs) -> + Vars = tl(FunList) -- [Goal], + lists:foldl( + fun({N} = Var, UBs1) -> + add_binding(Var, lists:nth(N, Key), UBs1) + end, Bs, Vars). + +index_of(Item, List) -> index_of(Item, List, 1). + +index_of(_, [], _) -> not_found; +index_of(Item, [Item | _], Index) -> Index; +index_of(Item, [_ | Tl], Index) -> index_of(Item, Tl, Index + 1). + +write(Res, Bs) when is_list(Res) -> + case io_lib:printable_list(Res) of + true -> Res; + false -> erlog_ec_support:dderef(Res, Bs) + end; +write(Res, Bs) -> + write([Res], Bs). + +cut(Label, Last, Param = #param{next_goal = Next, choice = [#cut{label = Label} | Cps] = Cps0}) -> + if Last -> erlog_ec_core:prove_body(Param#param{goal = Next, choice = Cps}); + true -> erlog_ec_core:prove_body(Param#param{goal = Next, choice = Cps0}) + end; +cut(Label, Last, Param = #param{next_goal = Next, choice = [#cp{type = if_then_else, label = Label} | Cps] = Cps0}) -> + if Last -> erlog_ec_core:prove_body(Param#param{goal = Next, choice = Cps}); + true -> erlog_ec_core:prove_body(Param#param{goal = Next, choice = Cps0}) + end; +cut(Label, Last, Param = #param{choice = [#cp{type = goal_clauses, label = Label} = Cp | Cps]}) -> + cut_goal_clauses(Last, Cp, Param#param{choice = Cps}); +cut(Label, Last, Param = #param{choice = [_Cp | Cps]}) -> + cut(Label, Last, Param#param{choice = Cps}). + + +%% @private +remove_nth(List, N) -> + {A, B} = lists:split(N - 1, List), + A ++ tl(B). + +%% @private +%% cut_goal_clauses(Last, Next, Cp, Cps, Bs, Vn, Db). +cut_goal_clauses(true, #cp{label = _}, Param = #param{next_goal = Next}) -> + %% Just remove the choice point completely and continue. + erlog_ec_core:prove_body(Param#param{goal = Next}); +cut_goal_clauses(false, #cp{label = L}, Param = #param{next_goal = Next, choice = Cps}) -> + %% Replace choice point with cut point then continue. + Cut = #cut{label = L}, + erlog_ec_core:prove_body(Param#param{goal = Next, choice = [Cut | Cps]}). + +%% @private +%% Get unbound vars from goal +get_var(N = {I}, Acc) when is_integer(I)-> [N | Acc]; +get_var(Tuple, Acc) when is_tuple(Tuple) -> get_var(tuple_to_list(Tuple), Acc); +get_var([First | Rest], Acc) -> + FirstPrep = get_var(First, []), + get_var(Rest, [FirstPrep | Acc]); +get_var(_, Acc) -> Acc. \ No newline at end of file diff --git a/src/core/logic/erlog_ec_term.erl b/src/core/logic/erlog_ec_term.erl new file mode 100644 index 0000000..49d44a1 --- /dev/null +++ b/src/core/logic/erlog_ec_term.erl @@ -0,0 +1,49 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 15. Июль 2014 16:29 +%%%------------------------------------------------------------------- +-module(erlog_ec_term). +-author("tihon"). + +%% API +-export([term_instance/2, term_instance/3]). + +%% term_instance(Term, VarNum) -> {Term,NewRepls,NewVarNum}. +%% term_instance(Term, Repls, VarNum) -> {Term,NewRepls,NewVarNum}. +%% Generate a copy of a term with new, fresh unused variables. No +%% bindings from original variables to new variables. It can handle +%% replacing integer variables with overlapping integer ranges. Don't +%% check Term as it should already be checked. Use orddict as there +%% will seldom be many variables and it it fast to setup. +term_instance(A, Vn) -> term_instance(A, orddict:new(), Vn). + +term_instance([], Rs, Vn) -> {[], Rs, Vn}; +term_instance([H0 | T0], Rs0, Vn0) -> + {H, Rs1, Vn1} = term_instance(H0, Rs0, Vn0), + {T, Rs2, Vn2} = term_instance(T0, Rs1, Vn1), + {[H | T], Rs2, Vn2}; +term_instance({'_'}, Rs, Vn) -> {{Vn}, Rs, Vn + 1}; %Unique variable +term_instance({V0}, Rs0, Vn0) -> %Other variables + case orddict:find(V0, Rs0) of + {ok, V1} -> {V1, Rs0, Vn0}; + error -> + V1 = {Vn0}, + {V1, orddict:store(V0, V1, Rs0), Vn0 + 1} + end; +%% Special case some smaller structures. +term_instance({Atom, Arg}, Rs0, Vn0) -> + {CopyArg, Rs1, Vn1} = term_instance(Arg, Rs0, Vn0), + {{Atom, CopyArg}, Rs1, Vn1}; +term_instance({Atom, A1, A2}, Rs0, Vn0) -> + {CopyA1, Rs1, Vn1} = term_instance(A1, Rs0, Vn0), + {CopyA2, Rs2, Vn2} = term_instance(A2, Rs1, Vn1), + {{Atom, CopyA1, CopyA2}, Rs2, Vn2}; +term_instance(T, Rs0, Vn0) when is_tuple(T) -> + As0 = tl(tuple_to_list(T)), + {As1, Rs1, Vn1} = term_instance(As0, Rs0, Vn0), + {list_to_tuple([element(1, T) | As1]), Rs1, Vn1}; +term_instance(A, Rs, Vn) -> {A, Rs, Vn}. %Constant \ No newline at end of file diff --git a/src/core/logic/erlog_ec_unify.erl b/src/core/logic/erlog_ec_unify.erl new file mode 100644 index 0000000..ad584da --- /dev/null +++ b/src/core/logic/erlog_ec_unify.erl @@ -0,0 +1,113 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 15. Июль 2014 16:26 +%%%------------------------------------------------------------------- +-module(erlog_ec_unify). +-author("tihon"). + +-include("erlog_core.hrl"). + +%% API +-export([unify/3, unify_clauses/4, unify_head/4, unify_clause/5]). + +%% unify(Term, Term, Bindings) -> {succeed,NewBindings} | fail. +%% Unify two terms with a set of bindings. +unify(T10, T20, Bs0) -> + case {erlog_ec_support:deref(T10, Bs0), erlog_ec_support:deref(T20, Bs0)} of + {T1, T2} when ?IS_CONSTANT(T1), T1 == T2 -> + {succeed, Bs0}; + {{V}, {V}} -> {succeed, Bs0}; + {{_} = Var, T2} -> {succeed, erlog_ec_support:add_binding(Var, T2, Bs0)}; + {T1, {_} = Var} -> {succeed, erlog_ec_support:add_binding(Var, T1, Bs0)}; + {[H1 | T1], [H2 | T2]} -> + case unify(H1, H2, Bs0) of + {succeed, Bs1} -> unify(T1, T2, Bs1); + fail -> fail + end; + {[], []} -> {succeed, Bs0}; + {T1, T2} when tuple_size(T1) == tuple_size(T2), + element(1, T1) == element(1, T2) -> + unify_args(T1, T2, Bs0, 2, tuple_size(T1)); + _Other -> fail + end. + +%% Try to unify Head and Body using Clauses which all have the same functor. +unify_clauses(_Ch, _Cb, [], Param) -> erlog_errors:fail(Param); %no more clauses to try +unify_clauses(Ch, Cb, C, Param = #param{next_goal = Next, bindings = Bs0, var_num = Vn0, choice = Cps, database = Db, cursor = Cursor}) -> + case unify_clause(Ch, Cb, C, Bs0, Vn0) of + {succeed, Bs1, Vn1} -> + Cp = #cp{type = clause, data = {Ch, Cb, Db, Cursor}, next = Next, bs = Bs0, vn = Vn0}, + erlog_ec_core:prove_body(Param#param{goal = Next, choice = [Cp | Cps], bindings = Bs1, var_num = Vn1}); + fail -> + {{UCursor, Res}, UDb} = erlog_memory:next(Db, Cursor), + unify_clauses(Ch, Cb, Res, Param#param{cursor = UCursor, database = UDb}) + end. + +unify_clause(Ch, Cb, [C], Bs0, Vn0) -> unify_clause(Ch, Cb, C, Bs0, Vn0); +unify_clause(Ch, Cb, {_Tag, H0, {B0, _}}, Bs0, Vn0) -> + {H1, Rs1, Vn1} = erlog_ec_term:term_instance(H0, Vn0), %Unique vars on head first + case unify(Ch, H1, Bs0) of + {succeed, Bs1} -> + {B1, _Rs2, Vn2} = erlog_ec_body:body_term(B0, Rs1, Vn1), %Now we need the rest + case unify(Cb, B1, Bs1) of + {succeed, Bs2} -> {succeed, Bs2, Vn2}; + fail -> fail + end; + fail -> fail + end. + +%% unify_head(Goal, Head, Bindings, VarNum) -> +%% {succeed,Repls,NewBindings,NewVarNum} | fail +%% Unify a goal with a head without creating an instance of the +%% head. This saves us creating many variables which are local to the +%% clause and saves many variable bindings. +unify_head(Goal, Head, Bs, Vn) -> + unify_head(erlog_ec_support:deref(Goal, Bs), Head, orddict:new(), Bs, Vn). + +unify_head(G, H, Rs, Bs, Vn) when ?IS_CONSTANT(G), G == H -> + {succeed, Rs, Bs, Vn}; +unify_head(_T, {'_'}, Rs, Bs, Vn) -> {succeed, Rs, Bs, Vn}; +unify_head(T, {V0}, Rs, Bs0, Vn) -> + %% Now for the tricky bit! + case orddict:find(V0, Rs) of + {ok, V1} -> %Already have a replacement + case unify(T, V1, Bs0) of + {succeed, Bs1} -> {succeed, Rs, Bs1, Vn}; + fail -> fail + end; + error -> %Add a replacement + {succeed, orddict:store(V0, T, Rs), Bs0, Vn} + end; +unify_head({_} = Var, H0, Rs0, Bs, Vn0) -> + %% Must have an instance here. + {H1, Rs1, Vn1} = erlog_ec_term:term_instance(H0, Rs0, Vn0), + {succeed, Rs1, erlog_ec_support:add_binding(Var, H1, Bs), Vn1}; +unify_head([GH | GT], [HH | HT], Rs0, Bs0, Vn0) -> + case unify_head(erlog_ec_support:deref(GH, Bs0), HH, Rs0, Bs0, Vn0) of + {succeed, Rs1, Bs1, Vn1} -> unify_head(erlog_ec_support:deref(GT, Bs1), HT, Rs1, Bs1, Vn1); + fail -> fail + end; +unify_head([], [], Rs, Bs, Vn) -> {succeed, Rs, Bs, Vn}; +unify_head(G, H, Rs, Bs, Vn) when tuple_size(G) == tuple_size(H), + element(1, G) == element(1, H) -> + unify_head_args(G, H, Rs, Bs, Vn, 2, tuple_size(G)); +unify_head(_G, _H, _Rs, _Bs, _Vn) -> fail. + +unify_head_args(_G, _H, Rs, Bs, Vn, I, S) when I > S -> + {succeed, Rs, Bs, Vn}; +unify_head_args(G, H, Rs0, Bs0, Vn0, I, S) -> + case unify_head(erlog_ec_support:deref(element(I, G), Bs0), element(I, H), Rs0, Bs0, Vn0) of + {succeed, Rs1, Bs1, Vn1} -> unify_head_args(G, H, Rs1, Bs1, Vn1, I + 1, S); + fail -> fail + end. + +unify_args(_, _, Bs, I, S) when I > S -> {succeed, Bs}; +unify_args(S1, S2, Bs0, I, S) -> + case unify(element(I, S1), element(I, S2), Bs0) of + {succeed, Bs1} -> unify_args(S1, S2, Bs1, I + 1, S); + fail -> fail + end. \ No newline at end of file diff --git a/src/erlog.app.src b/src/erlog.app.src new file mode 100644 index 0000000..94b2b24 --- /dev/null +++ b/src/erlog.app.src @@ -0,0 +1,16 @@ +{application, erlog, + [ + {description, "Erlog , Prolog in Erlang"}, + {vsn, "3.0"}, + {registered, []}, + {applications, [ + kernel, + stdlib, + inets + ]}, + {mod, {erlog_app, []}}, + {env, + [ + {console_port, 8080} + ]} + ]}. diff --git a/src/erlog.erl b/src/erlog.erl deleted file mode 100644 index 361cae9..0000000 --- a/src/erlog.erl +++ /dev/null @@ -1,209 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog.erl -%% Author : Robert Virding -%% Purpose : Main interface to the Erlog interpreter. -%% -%% Structures - {Functor,arg1, Arg2,...} where Functor is an atom -%% Variables - {Name} where Name is an atom or integer -%% Lists - Erlang lists -%% Atomic - Erlang constants -%% -%% There is no problem with the representation of variables as Prolog -%% functors of arity 0 are atoms. This representation is much easier -%% to test for, and create new variables with than using funny atom -%% names like '$1' (yuch!), and we need LOTS of variables. - --module(erlog). - --include("erlog_int.hrl"). - -%% Basic evaluator interface. --export([new/0]). -%% Interface to server. --export([start/0,start_link/0]). --export([prove/2,next_solution/1, - consult/2,reconsult/2,get_db/1,set_db/2,halt/1]). --export([init/1,handle_call/3,handle_cast/2,handle_info/2,terminate/2, - code_change/3]). -%% User utilities. --export([is_legal_term/1,vars_in/1]). - --import(lists, [foldl/3,foreach/2]). - --behaviour(gen_server). --vsn('0.6'). - -%% -compile(export_all). - -%% new() -> erlog(). -%% Define an Erlog instance. This is a fun which is called with the -%% top-level command and returns the result and the continutation in -%% a new fun. - -new() -> - Db0 = erlog_int:built_in_db(), %Basic interpreter predicates - Db1 = foldl(fun (Mod, Db) -> Mod:load(Db) end, Db0, - [erlog_bips, %Built in predicates - erlog_dcg, %DCG predicates - erlog_lists %Common lists library - ]), - fun (Cmd) -> top_cmd(Cmd, Db1) end. - -top_cmd({prove,Goal}, Db) -> - prove_goal(Goal, Db); -top_cmd(next_solution, Db) -> - {fail,fun (Cmd) -> top_cmd(Cmd, Db) end}; -top_cmd({consult,File}, Db0) -> - case erlog_file:consult(File, Db0) of - {ok,Db1} -> {ok,fun (Cmd) -> top_cmd(Cmd, Db1) end}; - {erlog_error,Error} -> - {{error,Error},fun (Cmd) -> top_cmd(Cmd, Db0) end}; - {error,Error} -> - {{error,Error},fun (Cmd) -> top_cmd(Cmd, Db0) end} - end; -top_cmd({reconsult,File}, Db0) -> - case erlog_file:reconsult(File, Db0) of - {ok,Db1} -> {ok,fun (Cmd) -> top_cmd(Cmd, Db1) end}; - {erlog_error,Error} -> - {{error,Error},fun (Cmd) -> top_cmd(Cmd, Db0) end}; - {error,Error} -> - {{error,Error},fun (Cmd) -> top_cmd(Cmd, Db0) end} - end; -top_cmd(get_db, Db) -> - {{ok,Db},fun (Cmd) -> top_cmd(Cmd, Db) end}; -top_cmd({set_db,NewDb}, _Db) -> - {ok,fun (Cmd) -> top_cmd(Cmd, NewDb) end}; -top_cmd(halt, _Db) -> ok. - -prove_goal(Goal0, Db) -> - Vs = vars_in(Goal0), - %% Goal may be a list of goals, ensure proper goal. - Goal1 = unlistify(Goal0), - %% Must use 'catch' here as 'try' does not do last-call - %% optimisation. - prove_result(catch erlog_int:prove_goal(Goal1, Db), Vs, Db). - -unlistify([G]) -> G; -unlistify([G|Gs]) -> {',',G,unlistify(Gs)}; -unlistify([]) -> true; -unlistify(G) -> G. %In case it wasn't a list. - -prove_result({succeed,Cps,Bs,Vn,Db1}, Vs, _Db0) -> - {{succeed,erlog_int:dderef(Vs, Bs)}, - fun (Cmd) -> prove_cmd(Cmd, Vs, Cps, Bs, Vn, Db1) end}; -prove_result({fail,Db1}, _Vs, _Db0) -> - {fail,fun (Cmd) -> top_cmd(Cmd, Db1) end}; -prove_result({erlog_error,Error,Db1}, _Vs, _Db0) -> - {{error,Error},fun (Cmd) -> top_cmd(Cmd, Db1) end}; -prove_result({erlog_error,Error}, _Vs, Db) -> %No new database - {{error,Error},fun (Cmd) -> top_cmd(Cmd, Db) end}; -prove_result({'EXIT',Error}, _Vs, Db) -> - {{'EXIT',Error},fun (Cmd) -> top_cmd(Cmd, Db) end}. - -prove_cmd(next_solution, Vs, Cps, _Bs, _Vn, Db) -> - prove_result(catch erlog_int:fail(Cps, Db), Vs, Db); -prove_cmd(Cmd, _Vs, _Cps, _Bs, _Vn, Db) -> - top_cmd(Cmd, Db). - -%% prove(Erlog, Goal) -> {succeed,Bindings} | fail. -%% next_solution(Erlog) -> {succeed,Bindings} | fail. -%% consult(Erlog, File) -> ok | {error,Error}. -%% reconsult(Erlog, File) -> ok | {error,Error}. -%% get_db(Erlog) -> {ok,Database}. -%% set_db(Erlog, Database) -> ok. -%% halt(Erlog) -> ok. -%% Interface functions to server. - -prove(Erl, Goal) when is_list(Goal) -> - {ok, TS, _ } = erlog_scan:string(Goal ++ " "), - {ok, G} = erlog_parse:term(TS), - prove(Erl, G); -prove(Erl, Goal) -> gen_server:call(Erl, {prove,Goal}, infinity). - -next_solution(Erl) -> gen_server:call(Erl, next_solution, infinity). - -consult(Erl, File) -> gen_server:call(Erl, {consult,File}, infinity). - -reconsult(Erl, File) -> gen_server:call(Erl, {reconsult,File}, infinity). - -get_db(Erl) -> gen_server:call(Erl, get_db, infinity). - -set_db(Erl, Db) -> gen_server:call(Erl, {set_db,Db}, infinity). - -halt(Erl) -> gen_server:cast(Erl, halt). - -%% Erlang server code. --record(state, {erlog}). %Erlog state - -start() -> - gen_server:start(?MODULE, [], []). - -start_link() -> - gen_server:start_link(?MODULE, [], []). - -init(_) -> - {ok,#state{erlog=new()}}. - -handle_call(Req, _, St) -> - {Res,Erl} = (St#state.erlog)(Req), - {reply,Res,St#state{erlog=Erl}}. - -handle_cast(halt, St) -> - {stop,normal,St}. - -handle_info(_, St) -> - {noreply,St}. - -terminate(_, St) -> - (St#state.erlog)(halt). - -code_change(_, _, St) -> {ok,St}. - -%% vars_in(Term) -> [{Name,Var}]. -%% Returns an ordered list of {VarName,Variable} pairs. - -vars_in(Term) -> vars_in(Term, orddict:new()). - -vars_in({'_'}, Vs) -> Vs; %Never in! -vars_in({Name}=Var, Vs) -> orddict:store(Name, Var, Vs); -vars_in(Struct, Vs) when is_tuple(Struct) -> - vars_in_struct(Struct, 2, size(Struct), Vs); -vars_in([H|T], Vs) -> - vars_in(T, vars_in(H, Vs)); -vars_in(_, Vs) -> Vs. - -vars_in_struct(_Str, I, S, Vs) when I > S -> Vs; -vars_in_struct(Str, I, S, Vs) -> - vars_in_struct(Str, I+1, S, vars_in(element(I, Str), Vs)). - -%% is_legal_term(Goal) -> true | false. -%% Test if a goal is a legal Erlog term. Basically just check if -%% tuples are used correctly as structures and variables. - -is_legal_term({V}) -> is_atom(V); -is_legal_term([H|T]) -> - is_legal_term(H) andalso is_legal_term(T); -is_legal_term(T) when is_tuple(T) -> - if tuple_size(T) >= 2, is_atom(element(1, T)) -> - are_legal_args(T, 2, size(T)); %The right tuples. - true -> false - end; -is_legal_term(T) when ?IS_ATOMIC(T) -> true; %All constants, including [] -is_legal_term(_T) -> false. - -are_legal_args(_T, I, S) when I > S -> true; -are_legal_args(T, I, S) -> - is_legal_term(element(I, T)) andalso are_legal_args(T, I+1, S). diff --git a/src/erlog_bips.erl b/src/erlog_bips.erl deleted file mode 100644 index d5bf00e..0000000 --- a/src/erlog_bips.erl +++ /dev/null @@ -1,382 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_bips.erl -%% Author : Robert Virding -%% Purpose : Built-in predicates of Erlog interpreter. -%% -%% These are the built-in predicates of the Prolog interpreter which -%% are not control predicates or database predicates. - --module(erlog_bips). - --include("erlog_int.hrl"). - -%% Main interface functions. --export([load/1]). --export([prove_goal/6]). - -%%-compile(export_all). - --import(lists, [map/2,foldl/3]). - -%% We use these a lot so we import them for cleaner code. --import(erlog_int, [prove_body/5,unify_prove_body/7,unify_prove_body/9,fail/2, - add_binding/3,make_vars/2, - deref/2,dderef/2,dderef_list/2,unify/3, - term_instance/2, - add_built_in/2,add_compiled_proc/4, - asserta_clause/2,assertz_clause/2]). - -%% load(Database) -> Database. -%% Assert predicates into the database. - -load(Db0) -> - foldl(fun (Head, Db) -> add_built_in(Head, Db) end, Db0, - [ - %% Term unification and comparison - {'=',2}, - {'\\=',2}, - {'@>',2}, - {'@>=',2}, - {'==',2}, - {'\\==',2}, - {'@<',2}, - {'@=<',2}, - %% Term creation and decomposition. - {arg,3}, - {copy_term,2}, - {functor,3}, - {'=..',2}, - %% Type testing. - {atom,1}, - {atomic,1}, - {compound,1}, - {integer,1}, - {float,1}, - {number,1}, - {nonvar,1}, - {var,1}, - %% Atom processing. - {atom_chars,2}, - {atom_length,2}, - %% Arithmetic evaluation and comparison - {'is',2}, - {'>',2}, - {'>=',2}, - {'=:=',2}, - {'=\\=',2}, - {'<',2}, - {'=<',2} - ]). - -%% prove_goal(Goal, NextGoal, ChoicePoints, Bindings, VarNum, Database) -> -%% {succeed,ChoicePoints,NewBindings,NewVarNum,NewDatabase} | -%% {fail,NewDatabase}. -%% Prove one goal. We seldom return succeed here but usually go directly to -%% to NextGoal. - -%% Term unification and comparison -prove_goal({'=',L,R}, Next, Cps, Bs, Vn, Db) -> - unify_prove_body(L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'\\=',L,R}, Next, Cps, Bs0, Vn, Db) -> - case unify(L, R, Bs0) of - {succeed,_Bs1} -> fail(Cps, Db); - fail -> prove_body(Next, Cps, Bs0, Vn, Db) - end; -prove_goal({'@>',L,R}, Next, Cps, Bs, Vn, Db) -> - term_test_prove_body('>', L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'@>=',L,R}, Next, Cps, Bs, Vn, Db) -> - term_test_prove_body('>=', L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'==',L,R}, Next, Cps, Bs, Vn, Db) -> - term_test_prove_body('==', L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'\\==',L,R}, Next, Cps, Bs, Vn, Db) -> - term_test_prove_body('/=', L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'@<',L,R}, Next, Cps, Bs, Vn, Db) -> - term_test_prove_body('<', L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'@=<',L,R}, Next, Cps, Bs, Vn, Db) -> - term_test_prove_body('=<', L, R, Next, Cps, Bs, Vn, Db); -%% Term creation and decomposition. -prove_goal({arg,I,Ct,A}, Next, Cps, Bs, Vn, Db) -> - prove_arg(deref(I, Bs), deref(Ct, Bs), A, Next, Cps, Bs, Vn, Db); -prove_goal({copy_term,T0,C}, Next, Cps, Bs, Vn0, Db) -> - %% Use term_instance to create the copy, can ignore orddict it creates. - {T,_Nbs,Vn1} = term_instance(dderef(T0, Bs), Vn0), - unify_prove_body(T, C, Next, Cps, Bs, Vn1, Db); -prove_goal({functor,T,F,A}, Next, Cps, Bs, Vn, Db) -> - prove_functor(dderef(T, Bs), F, A, Next, Cps, Bs, Vn, Db); -prove_goal({'=..',T,L}, Next, Cps, Bs, Vn, Db) -> - prove_univ(dderef(T, Bs), L, Next, Cps, Bs, Vn, Db); -%% Type testing. -prove_goal({atom,T0}, Next, Cps, Bs, Vn, Db) -> - case deref(T0, Bs) of - T when is_atom(T) -> prove_body(Next, Cps, Bs, Vn, Db); - _Other -> fail(Cps, Db) - end; -prove_goal({atomic,T0}, Next, Cps, Bs, Vn, Db) -> - case deref(T0, Bs) of - T when ?IS_ATOMIC(T) -> prove_body(Next, Cps, Bs, Vn, Db); - _Other -> fail(Cps, Db) - end; -prove_goal({compound,T0}, Next, Cps, Bs, Vn, Db) -> - case deref(T0, Bs) of - T when ?IS_ATOMIC(T) -> fail(Cps, Db); - _Other -> prove_body(Next, Cps, Bs, Vn, Db) - end; -prove_goal({integer,T0}, Next, Cps, Bs, Vn, Db) -> - case deref(T0, Bs) of - T when is_integer(T) -> prove_body(Next, Cps, Bs, Vn, Db); - _Other -> fail(Cps, Db) - end; -prove_goal({float,T0}, Next, Cps, Bs, Vn, Db) -> - case deref(T0, Bs) of - T when is_float(T) -> prove_body(Next, Cps, Bs, Vn, Db); - _Other -> fail(Cps, Db) - end; -prove_goal({number,T0}, Next, Cps, Bs, Vn, Db) -> - case deref(T0, Bs) of - T when is_number(T) -> prove_body(Next, Cps, Bs, Vn, Db); - _Other -> fail(Cps, Db) - end; -prove_goal({nonvar,T0}, Next, Cps, Bs, Vn, Db) -> - case deref(T0, Bs) of - {_} -> fail(Cps, Db); - _Other -> prove_body(Next, Cps, Bs, Vn, Db) - end; -prove_goal({var,T0}, Next, Cps, Bs, Vn, Db) -> - case deref(T0, Bs) of - {_} -> prove_body(Next, Cps, Bs, Vn, Db); - _Other -> fail(Cps, Db) - end; -%% Atom processing. -prove_goal({atom_chars,A,L}, Next, Cps, Bs, Vn, Db) -> - prove_atom_chars(A, L, Next, Cps, Bs, Vn, Db); -prove_goal({atom_length,A0,L0}, Next, Cps, Bs, Vn, Db) -> - case dderef(A0, Bs) of - A when is_atom(A) -> - Alen = length(atom_to_list(A)), %No of chars in atom - case dderef(L0, Bs) of - L when is_integer(L) -> - unify_prove_body (Alen, L, Next, Cps, Bs, Vn, Db); - {_}=Var -> - unify_prove_body (Alen, Var, Next, Cps, Bs, Vn, Db); - Other -> erlog_int:type_error(integer, Other, Db) - end; - {_} -> erlog_int:instantiation_error(Db); - Other -> erlog_int:type_error(atom, Other, Db) - end; -%% Arithmetic evalution and comparison. -prove_goal({is,N,E0}, Next, Cps, Bs, Vn, Db) -> - E = eval_arith(deref(E0, Bs), Bs, Db), - unify_prove_body(N, E, Next, Cps, Bs, Vn, Db); -prove_goal({'>',L,R}, Next, Cps, Bs, Vn, Db) -> - arith_test_prove_body('>', L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'>=',L,R}, Next, Cps, Bs, Vn, Db) -> - arith_test_prove_body('>=', L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'=:=',L,R}, Next, Cps, Bs, Vn, Db) -> - arith_test_prove_body('==', L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'=\\=',L,R}, Next, Cps, Bs, Vn, Db) -> - arith_test_prove_body('/=', L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'<',L,R}, Next, Cps, Bs, Vn, Db) -> - arith_test_prove_body('<', L, R, Next, Cps, Bs, Vn, Db); -prove_goal({'=<',L,R}, Next, Cps, Bs, Vn, Db) -> - arith_test_prove_body('=<', L, R, Next, Cps, Bs, Vn, Db). - -%% term_test_prove_body(Test, Left, Right, Next, ChoicePoints, Bindings, Varnum, Database) -> -%% void. - -term_test_prove_body(Test, L, R, Next, Cps, Bs, Vn, Db) -> - case erlang:Test(dderef(L, Bs), dderef(R, Bs)) of - true -> prove_body(Next, Cps, Bs, Vn, Db); - false -> fail(Cps, Db) - end. - -%% prove_arg(Index, Term, Arg, Next, ChoicePoints, VarNum, Database) -> void. -%% Prove the goal arg(I, Ct, Arg), Index and Term have been dereferenced. - -prove_arg(I, [H|T], A, Next, Cps, Bs, Vn, Db) when is_integer(I) -> - %% He, he, he! - if I == 1 -> unify_prove_body(H, A, Next, Cps, Bs, Vn, Db); - I == 2 -> unify_prove_body(T, A, Next, Cps, Bs, Vn, Db); - true -> {fail,Db} - end; -prove_arg(I, Ct, A, Next, Cps, Bs, Vn, Db) - when is_integer(I), tuple_size(Ct) >= 2 -> - if I > 1, I + 1 =< tuple_size(Ct) -> - unify_prove_body(element(I+1, Ct), A, Next, Cps, Bs, Vn, Db); - true -> {fail,Db} - end; -prove_arg(I, Ct, _, _, _, _, _, Db) -> - %%Type failure just generates an error. - if not(is_integer(I)) -> erlog_int:type_error(integer, I, Db); - true -> erlog_int:type_error(compound, Ct, Db) - end. - -%% prove_functor(Term, Functor, Arity, Next, ChoicePoints, Bindings, VarNum, Database) -> void. -%% Prove the call functor(T, F, A), Term has been dereferenced. - -prove_functor(T, F, A, Next, Cps, Bs, Vn, Db) when tuple_size(T) >= 2 -> - unify_prove_body(F, element(1, T), A, tuple_size(T)-1, Next, Cps, Bs, Vn, Db); -prove_functor(T, F, A, Next, Cps, Bs, Vn, Db) when ?IS_ATOMIC(T) -> - unify_prove_body(F, T, A, 0, Next, Cps, Bs, Vn, Db); -prove_functor([_|_], F, A, Next, Cps, Bs, Vn, Db) -> - %% Just the top level here. - unify_prove_body(F, '.', A, 2, Next, Cps, Bs, Vn, Db); -prove_functor({_}=Var, F0, A0, Next, Cps, Bs0, Vn0, Db) -> - case {dderef(F0, Bs0),dderef(A0, Bs0)} of - {'.',2} -> %He, he, he! - Bs1 = add_binding(Var, [{Vn0}|{Vn0+1}], Bs0), - prove_body(Next, Cps, Bs1, Vn0+2, Db); - {F1,0} when ?IS_ATOMIC(F1) -> - Bs1 = add_binding(Var, F1, Bs0), - prove_body(Next, Cps, Bs1, Vn0, Db); - {F1,A1} when is_atom(F1), is_integer(A1), A1 > 0 -> - As = make_vars(A1, Vn0), - Bs1 = add_binding(Var, list_to_tuple([F1|As]), Bs0), - prove_body(Next, Cps, Bs1, Vn0+A1, Db); %!!! - %% Now the error cases. - {{_},_} -> erlog_int:instantiation_error(Db); - {F1,A1} when is_atom(F1) -> erlog_int:type_error(integer, A1, Db); - {F1,_} -> erlog_int:type_error(atom, F1, Db) - end. - -%% prove_univ(Term, List, Next, ChoicePoints, Bindings, VarNum, Database) -> void. -%% Prove the goal Term =.. List, Term has already been dereferenced. - -prove_univ(T, L, Next, Cps, Bs, Vn, Db) when tuple_size(T) >= 2 -> - Es = tuple_to_list(T), - unify_prove_body(Es, L, Next, Cps, Bs, Vn, Db); -prove_univ(T, L, Next, Cps, Bs, Vn, Db) when ?IS_ATOMIC(T) -> - unify_prove_body([T], L, Next, Cps, Bs, Vn, Db); -prove_univ([Lh|Lt], L, Next, Cps, Bs, Vn, Db) -> - %% He, he, he! - unify_prove_body(['.',Lh,Lt], L, Next, Cps, Bs, Vn, Db); -prove_univ({_}=Var, L, Next, Cps, Bs0, Vn, Db) -> - case dderef(L, Bs0) of - ['.',Lh,Lt] -> %He, he, he! - Bs1 = add_binding(Var, [Lh|Lt], Bs0), - prove_body(Next, Cps, Bs1, Vn, Db); - [A] when ?IS_ATOMIC(A) -> - Bs1 = add_binding(Var, A, Bs0), - prove_body(Next, Cps, Bs1, Vn, Db); - [F|As] when is_atom(F), length(As) > 0 -> - Bs1 = add_binding(Var, list_to_tuple([F|As]), Bs0), - prove_body(Next, Cps, Bs1, Vn, Db); - %% Now the error cases. - [{_}|_] -> erlog_int:instantiation_error(Db); - {_} -> erlog_int:instantiation_error(Db); - Other -> erlog_int:type_error(list, Other, Db) -end. - -%% prove_atom_chars(Atom, List, Next, ChoicePoints, Bindings, VarNum, Database) -> -%% void. -%% Prove the atom_chars(Atom, List). - -prove_atom_chars(A, L, Next, Cps, Bs, Vn, Db) -> - %% After a suggestion by Sean Cribbs. - case dderef(A, Bs) of - Atom when is_atom(Atom) -> - AtomList = [ list_to_atom([C]) || C <- atom_to_list(Atom) ], - unify_prove_body(L, AtomList, Next, Cps, Bs, Vn, Db); - {_}=Var -> - %% Error #3: List is neither a list nor a partial list. - %% Handled in dderef_list/2. - List = dderef_list(L, Bs), - %% Error #1, #4: List is a list or partial list with an - %% element which is a variable or not one char atom. - Fun = fun ({_}) -> erlog_int:instantiation_error(Db); - (Atom) -> - case is_atom(Atom) andalso atom_to_list(Atom) of - [C] -> C; - _ -> erlog_int:type_error(character, Atom, Db) - end - end, - Chars = lists:map(Fun, List), - Atom = list_to_atom(Chars), - unify_prove_body(Var, Atom, Next, Cps, Bs, Vn, Db); - Other -> - %% Error #2: Atom is neither a variable nor an atom - erlog_int:type_error(atom, Other, Db) - end. - -%% arith_test_prove_body(Test, Left, Right, Next, ChoicePoints, Bindings, VarNum, Database) -> -%% void. - -arith_test_prove_body(Test, L, R, Next, Cps, Bs, Vn, Db) -> - case erlang:Test(eval_arith(deref(L, Bs), Bs, Db), - eval_arith(deref(R, Bs), Bs, Db)) of - true -> prove_body(Next, Cps, Bs, Vn, Db); - false -> fail(Cps, Db) - end. - -%% eval_arith(ArithExpr, Bindings, Database) -> Number. -%% Evaluate an arithmetic expression, include the database for -%% errors. Dereference each level as we go, might fail so save some -%% work. Must be called deferenced. - -eval_arith({'+',A,B}, Bs, Db) -> - eval_arith(deref(A, Bs), Bs, Db) + eval_arith(deref(B, Bs), Bs, Db); -eval_arith({'-',A,B}, Bs, Db) -> - eval_arith(deref(A, Bs), Bs, Db) - eval_arith(deref(B, Bs), Bs, Db); -eval_arith({'*',A,B}, Bs, Db) -> - eval_arith(deref(A, Bs), Bs, Db) * eval_arith(deref(B, Bs), Bs, Db); -eval_arith({'/',A,B}, Bs, Db) -> - eval_arith(deref(A, Bs), Bs, Db) / eval_arith(deref(B, Bs), Bs, Db); -eval_arith({'**',A,B}, Bs, Db) -> - math:pow(eval_arith(deref(A, Bs), Bs, Db), - eval_arith(deref(B, Bs), Bs, Db)); -eval_arith({'//',A,B}, Bs, Db) -> - eval_int(deref(A, Bs), Bs, Db) div eval_int(deref(B, Bs), Bs, Db); -eval_arith({'mod',A,B}, Bs, Db) -> - eval_int(deref(A, Bs), Bs, Db) rem eval_int(deref(B, Bs), Bs, Db); -eval_arith({'/\\',A,B}, Bs, Db) -> - eval_int(deref(A, Bs), Bs, Db) band eval_int(deref(B, Bs), Bs, Db); -eval_arith({'\\/',A,B}, Bs, Db) -> - eval_int(deref(A, Bs), Bs, Db) bor eval_int(deref(B, Bs), Bs, Db); -eval_arith({'<<',A,B}, Bs, Db) -> - eval_int(deref(A, Bs), Bs, Db) bsl eval_int(deref(B, Bs), Bs, Db); -eval_arith({'>>',A,B}, Bs, Db) -> - eval_int(deref(A, Bs), Bs, Db) bsr eval_int(deref(B, Bs), Bs, Db); -eval_arith({'\\',A}, Bs, Db) -> - bnot eval_int(deref(A, Bs), Bs, Db); -eval_arith({'+',A}, Bs, Db) -> - + eval_arith(deref(A, Bs), Bs, Db); -eval_arith({'-',A}, Bs, Db) -> - - eval_arith(deref(A, Bs), Bs, Db); -eval_arith({'abs',A}, Bs, Db) -> - abs(eval_arith(deref(A, Bs), Bs, Db)); -eval_arith({'float',A}, Bs, Db) -> - float(eval_arith(deref(A, Bs), Bs, Db)); -eval_arith({'truncate',A}, Bs, Db) -> - trunc(eval_arith(deref(A, Bs), Bs, Db)); -eval_arith(N, _Bs, _Db) when is_number(N) -> N; %Just a number -%% Error cases. -eval_arith({_}, _Bs, Db) -> erlog_int:instantiation_error(Db); -eval_arith(N, _Bs, Db) when is_tuple(N) -> - Pi = pred_ind(element(1, N), tuple_size(N)-1), - erlog_int:type_error(evaluable, Pi, Db); -eval_arith([_|_], _Bs, Db) -> - erlog_int:type_error(evaluable, pred_ind('.', 2), Db); -eval_arith(O, _Bs, Db) -> erlog_int:type_error(evaluable, O, Db). - -%% eval_int(IntegerExpr, Bindings, Database) -> Integer. -%% Evaluate an integer expression, include the database for errors. - -eval_int(E0, Bs, Db) -> - E = eval_arith(E0, Bs, Db), - if is_integer(E) -> E; - true -> erlog_int:type_error(integer, E, Db) - end. - -pred_ind(N, A) -> {'/',N,A}. diff --git a/src/erlog_boot.erl b/src/erlog_boot.erl deleted file mode 100644 index da938a0..0000000 --- a/src/erlog_boot.erl +++ /dev/null @@ -1,33 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_boot.erl -%% Author : Robert Virding -%% Purpose : Erlog boot module. - -%% This little beauty allows you to start Erlang with the Erlog shell -%% running and still has ^G and user_drv enabled. Use it as follows: -%% -%% erl -noshell -noinput -s erlog_boot start -%% -%% NOTE order of commands important, must be -noshell -noinput! Add -%% -pa to find modules if necessary. -%% -%% Thanks to Attila Babo for showing me how to do this. - --module(erlog_boot). - --export([start/0]). - -start() -> user_drv:start(['tty_sl -c -e',{erlog_shell,start,[]}]). diff --git a/src/erlog_dcg.erl b/src/erlog_dcg.erl deleted file mode 100644 index 6253c9d..0000000 --- a/src/erlog_dcg.erl +++ /dev/null @@ -1,167 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_dcg.erl -%% Author : Robert Virding -%% Purpose : DCG conversion and procedures. - --module(erlog_dcg). - --include("erlog_int.hrl"). - --export([expand_term/1,expand_term/2]). --export([expand_term_2/6,phrase_3/6]). --export([load/1]). - --import(lists, [foldl/3]). - -%% We use these a lot so we import them for cleaner code. --import(erlog_int, [prove_body/5,unify_prove_body/7,unify_prove_body/9,fail/2, - add_binding/3,make_vars/2, - deref/2,dderef/2,dderef_list/2,unify/3, - term_instance/2, - add_built_in/2,add_compiled_proc/4, - asserta_clause/2,assertz_clause/2]). - -load(Db0) -> - %% Compiled DCG predicates. - Db1 = foldl(fun ({Head,M,F}, Db) -> add_compiled_proc(Head, M, F, Db) end, - Db0, - [ - {{expand_term,2},erlog_dcg,expand_term_2}, - {{phrase,3},erlog_dcg,phrase_3} - ]), - %% Interpreted DCG predicates. - foldl(fun (Clause, Db) -> assertz_clause(Clause, Db) end, Db1, - [ - %% 'C'([H|T], H, T). - %% {'C',[{1}|{2}],{1},{2}}, %For DCGs - %% phrase(V, L) :- phrase(V, L, []). - {':-',{phrase,{1},{2}},{phrase,{1},{2},[]}} - %% phrase(V, L, R) :- - %% V =.. Z, append(Z, [L,R], G), C =.. G, C. - %% {':-',{phrase,{1},{2},{3}}, - %% {',',{'=..',{1},{4}},{',',{append,{4},[{2},{3}],{5}}, - %% {',',{'=..',{6},{5}},{6}}}}} - ]). - -%% expand_term_2(Goal, NextGoal, ChoicePoints, Bindings, VarNum, Database) -> -%% void -%% Call the expand_term/2 predicate. - -expand_term_2(Goal, Next, Cps, Bs, Vn0, Db) -> - {expand_term,DCGRule,A2} = dderef(Goal, Bs), - {Exp,Vn1} = expand_term(DCGRule, Vn0), - unify_prove_body(A2, Exp, Next, Cps, Bs, Vn1, Db). - -%% phrase_3(Goal, NextGoal, ChoicePoints, Bindings, VarNum, Database) -> void. -%% Call the phrase/3 preidicate. We could easily do this in prolog -%% except for that it calls dcg_body/4 which is not exported. -%% -%% phrase(GRBody, S0, S) -> dcg_body(GRBody, S0, S, Goal), call(Goal). - -phrase_3(Goal, Next0, Cps, Bs, Vn0, Db) -> - {phrase,GRBody,S0,S} = dderef(Goal, Bs), - {Body,Vn1} = dcg_body(GRBody, S0, S, Vn0), - %% io:format("~p\n", [Body]), - Next1 = [{call,Body}|Next0], %Evaluate body - prove_body(Next1, Cps, Bs, Vn1, Db). - -%% expand_term(Term) -> {ExpTerm}. -%% expand_term(Term, VarNum) -> {ExpTerm,NewVarNum}. -%% Handle DCG expansion. We do NOT work backwards. - -expand_term(Term) -> - {Exp,_} = expand_term(Term, 0), - Exp. - -expand_term({'-->',_,_}=Term, Vn) -> - dcg_rule(Term, Vn); -expand_term(Term, Vn) -> {Term,Vn}. - -%% dcg_rule(Term, VarNum) -> {ExpTerm,NewVarNum}. -%% dcg_rule(DCGRule, VarIn, VarOout, VarNum) -> {ExpTerm,NewVarNum}. -%% dcg_non_term(NonTerminal, VarIn, VarOut) -> ExpTerm. -%% dcg_body(BodyTerm, VarIn, VarOut, VarNum) -> {ExpBody,NewVarOut,NewVarNum}. -%% dcg_goal(BodyGoal, VarIn, VarOut, VarNum) -> {ExpGaol,NewVarOut,NewVarNum}. -%% dcg_terminal(Terminals, VarIn, VarOut, VarNum) -> -%% {ExpTerms,NewVarOut,NewVarNum}. -%% dcg_body and dcg_goal do smae the thing except the dcg_body -%% guarantees the output variable is the one we specify. It may -%% insert an explicit '=' to get this. - -dcg_rule(DCGRule, Vn0) -> - S0 = {Vn0}, - S = {Vn0+1}, - dcg_rule(DCGRule, S0, S, Vn0+2). - -dcg_rule({'-->',{',',H,RHC},B}, S0, S, Vn0) -> - S1 = {Vn0}, - Head = dcg_non_term(H, S0, S), - {Goal1,S2,Vn1} = dcg_goal(B, S0, S1, Vn0+1), - {Goal2,Vn2} = dcg_terminals(RHC, S, S2, Vn1), - {{':-',Head,{',',Goal1,Goal2}},Vn2}; -dcg_rule({'-->',H,B}, S0, S, Vn0) -> - Head = dcg_non_term(H, S0, S), - {Body,Vn1} = dcg_body(B, S0, S, Vn0), - {{':-',Head,Body},Vn1}. - -dcg_non_term(A, S0, S) when is_atom(A) -> {A,S0,S}; -dcg_non_term(T, S0, S) when ?IS_FUNCTOR(T) -> - list_to_tuple(tuple_to_list(T) ++ [S0,S]); -dcg_non_term(Other, _, _) -> erlog_int:type_error(callable, Other). - -dcg_body({',',G0,B0}, S0, S, Vn0) -> - S1 = {Vn0}, - {G1,S2,Vn1} = dcg_goal(G0, S0, S1, Vn0+1), - {B1,Vn2} = dcg_body(B0, S2, S, Vn1), - {{',',G1,B1},Vn2}; -dcg_body(G0, S0, S, Vn0) -> - case dcg_goal(G0, S0, S, Vn0) of - {G1,S,Vn1} -> {G1,Vn1}; %Already uses S - {G1,S1,Vn1} -> %So we get S! - %% io:format("~p\n", [{G1,S0,S1,S}]), - {{',',G1,{'=',S1,S}},Vn1} - end. - -dcg_goal('!', S0, _, Vn) -> {'!',S0,Vn}; -dcg_goal({_}=V, S0, S, Vn) -> - {{phrase,V,S0,S},S,Vn}; -dcg_goal({'{}',G}, S0, _, Vn) -> {G,S0,Vn}; -dcg_goal({',',L0,R0}, S0, S, Vn0) -> - S1 = {Vn0}, - {L1,S2,Vn1} = dcg_goal(L0, S0, S1, Vn0+1), - {R1,S3,Vn2} = dcg_goal(R0, S2, S, Vn1), - {{',',L1,R1},S3,Vn2}; -dcg_goal({';',L0,R0}, S0, S, Vn0) -> - {L1,Vn1} = dcg_body(L0, S0, S, Vn0), - {R1,Vn2} = dcg_body(R0, S0, S, Vn1), - {{';',L1,R1},S,Vn2}; -dcg_goal({'->',GRIf,GRThen}, S0, S, Vn0) -> - S1 = {Vn0}, - {If,S2,Vn1} = dcg_goal(GRIf, S0, S1, Vn0+1), - {Then,S3,Vn2} = dcg_goal(GRThen, S2, S, Vn1), - {{'->',If,Then},S3,Vn2}; -dcg_goal({'\\+',G0}, S0, S, Vn) -> - {G1,_,_} = dcg_goal(G0, S0, S, Vn), - {{'\\+',G1},S0,Vn}; -dcg_goal(Lits, S0, S, Vn0) when is_list(Lits) -> - {ELits,Vn1} = dcg_terminals(Lits, S0, S, Vn0), - {ELits,S,Vn1}; -dcg_goal(NonT, S0, S, Vn) -> - Goal = dcg_non_term(NonT, S0, S), - {Goal,S,Vn}. - -dcg_terminals(Lits, S0, S, Vn) -> %Without 'C'/3 - {{'=',S0,Lits ++ S},Vn}. diff --git a/src/erlog_demo.erl b/src/erlog_demo.erl deleted file mode 100644 index ad3c1d6..0000000 --- a/src/erlog_demo.erl +++ /dev/null @@ -1,75 +0,0 @@ -%% Copyright (c) 2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_demo.erl -%% Author : Robert Virding -%% Purpose : Demo functions for Erlang interface of Erlog system. - --module(erlog_demo). - --export([efunc/1,ets_keys/1,get_list/1]). - -%% efunc(Fcall) -> {succeed_last,Val}. -%% ets_keys(Table) -> {succeed,Val,Cont} | {succeed_last,Val} | fail. -%% get_list(ListGenerator) -> {succeed,Val,Cont} | {succeed_last,Val} | fail. -%% Test/demo functions for ecall predicate. Examples of different ways -%% of generating solutions. - -efunc(Fcall) -> - %% Call an erlang function and return the value. - %% This is what the operators will generate. - Val = case Fcall of - {':',M,F} when is_atom(M), is_atom(F) -> M:F(); - {':',M,{F,A}} when is_atom(M), is_atom(F) -> M:F(A); - {':',M,T} when is_atom(M), is_tuple(T), size(T) >= 2, - is_atom(element(1, T)) -> - apply(M,element(1, T),tl(tuple_to_list(T))) - end, - {succeed_last,Val}. %Optimisation - -ets_keys(Tab) -> - %% Ets table keys back-trackable. - %% Solution with no look-ahead, get keys when requested. - %% This fun returns next key and itself for continuation. - F = fun (F1, Tab1, Last1) -> - case ets:next(Tab1, Last1) of - '$end_of_table' -> fail; %No more elements - Key1 -> {succeed,Key1, fun () -> F1(F1, Tab1, Key1) end} - end - end, - case ets:first(Tab) of - '$end_of_table' -> fail; %No elements - Key -> {succeed,Key, fun () -> F(F, Tab, Key) end} - end. - -get_list(ListGen) -> - %% List as back-trackable generator. - %% This is what the operators will generate. - Vals = case ListGen of - {':',M,F} when is_atom(M), is_atom(F) -> M:F(); - {':',M,{F,A}} when is_atom(M), is_atom(F) -> - M:F(A); - {':',M,T} when is_atom(M), is_tuple(T), size(T) >= 2, - is_atom(element(1, T)) -> - apply(M,element(1, T),tl(tuple_to_list(T))) - end, - %% This fun will return head and itself for continuation. - Fun = fun (F1, Es0) -> - case Es0 of - [E] -> {succeed_last,E}; %Optimisation for last one - [E|Es] -> {succeed,E,fun () -> F1(F1, Es) end}; - [] -> fail %No more elements - end - end, - Fun(Fun, Vals). %Call with list of values diff --git a/src/erlog_ets.erl b/src/erlog_ets.erl deleted file mode 100644 index 012a903..0000000 --- a/src/erlog_ets.erl +++ /dev/null @@ -1,149 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_ets.erl -%% Author : Robert Virding -%% Purpose : ETS interface for Erlog. - --module(erlog_ets). - --include("erlog_int.hrl"). - --compile(export_all). - --export([assert/1,all_1/6,keys_2/6,match_2/6]). - --import(lists, [foldl/3]). --import(erlog_int, [add_compiled_proc/4,dderef/2,unify/3, - prove_body/5,unify_prove_body/7,fail/2]). - -%% assert(Database) -> Database. -%% Assert predicates into the database. - -assert(Db) -> - foldl(fun ({Head,M,F}, LDb) -> - add_compiled_proc(Head, M, F, LDb) end, Db, - [ - {{ets_all,1},?MODULE,all_1}, - {{ets_keys,2},?MODULE,keys_2}, - {{ets_match,2},?MODULE,match_2} - ]). - - -%% all_1(Goal, Next, ChoicePoints, Bindings, VarNum, Database) -> void(). -%% Goal = {ets_all,Tables}. -%% Return all the ETS databases. - -all_1({ets_all,Var}, Next, Cps, Bs, Vn, Db) -> - Tabs = ets:all(), - unify_prove_body(Var, Tabs, Next, Cps, Bs, Vn, Db). - -%% keys_2(Goal, Next, ChoicePoints, Bindings, VarNum, Database) -> void(). -%% Goal = {ets_keys,Table,Key}. -%% Return the keys in an ETS database one at a time over backtracking. - -keys_2({ets_keys,Tab0,KeyVar}, Next, Cps, Bs, Vn, Db) -> - Tab1 = dderef(Tab0, Bs), - case ets:first(Tab1) of - '$end_of_table' -> fail(Cps, Db); - Key -> keys_loop(Tab1, Key, KeyVar, Next, Cps, Bs, Vn, Db) - end. - -keys_loop(Tab, Key, KeyVar, Next, Cps, Bs, Vn, Db) -> - FailFun = fun(LCp, LCps, LDb) -> - keys_fail(LCp, LCps, LDb, Tab, Key, KeyVar) - end, - C = #cp{type=compiled,data=FailFun,next=Next,bs=Bs,vn=Vn}, - unify_prove_body(KeyVar, Key, Next, [C|Cps], Bs, Vn, Db). - -keys_fail(#cp{next=Next,bs=Bs,vn=Vn}, Cps, Db, Tab, PrevKey, KeyVar) -> - case ets:next(Tab, PrevKey) of - '$end_of_table' -> fail(Cps, Db); - Key -> keys_loop(Tab, Key, KeyVar, Next, Cps, Bs, Vn, Db) - end. - -%% match_2(Goal, Next, ChoicePoints, Bindings, VarNum, Database) -> void(). -%% Goal = {ets_match,Table,Pattern}. -%% Match objects in an ETS database one at a time over backtracking -%% using Pattern in goal. Variables in Pattern are bound for each -%% object matched. - -match_2({ets_match,Tab0,Pat0}, Next, Cps, Bs, Vn, Db) -> - Tab1 = dderef(Tab0, Bs), - Pat1 = dderef(Pat0, Bs), - {Epat,Vs} = ets_pat(Pat1), - match_2_loop(ets:match(Tab1, Epat, 10), Next, Cps, Bs, Vn, Db, Epat, Vs). - -match_2_loop({[M|Ms],Cont}, Next, Cps, Bs, Vn, Db, Epat, Vs) -> - FailFun = fun (LCp, LCps, LDb) -> - match_2_fail(LCp, LCps, LDb, Epat, Vs, {Ms,Cont}) - end, - Cp = #cp{type=compiled,data=FailFun,next=Next,bs=Bs,vn=Vn}, - unify_prove_body(Vs, M, Next, [Cp|Cps], Bs, Vn, Db); -match_2_loop({[],Cont}, Next, Cps, Bs, Vn, Db, Epat, Vs) -> - match_2_loop(ets:match(Cont), Next, Cps, Bs, Vn, Db, Epat, Vs); -match_2_loop('$end_of_table', _Next, Cps, _Bs, _Vn, Db, _Epat, _Vs) -> - fail(Cps, Db). - -match_2_fail(#cp{next=Next,bs=Bs,vn=Vn}, Cps, Db, Epat, Vs, Ms) -> - match_2_loop(Ms, Next, Cps, Bs, Vn, Db, Epat, Vs). - -%% ets_pat(Term) -> {EtsPattern,VarList}. -%% Convert a term into an ETS pattern replacing variables with the ETS -%% pattern variables. Also return a list of variables in the same -%% order as ETS will return the list of values. This is slightly -%% tricky as the order they are in ETS which is not the same as term -%% order so they can not be easily sorted. Sigh! - -ets_pat(Pat) -> - {Epat,_Vn,Vs0} = ets_pat(Pat, 11, []), - Vs1 = [ V || {V,_Ev} <- Vs0 ], - {Epat,Vs1}. - -ets_pat({_}=V, Vn, Vs) -> - case find(V, Vs) of - {yes,Ev} -> {Ev,Vn,Vs}; - no -> - Ev = ets_var(Vn), - {Ev,Vn-1,[{V,Ev}|Vs]} - end; -ets_pat([H0|T0], Vn0, Vs0) -> - {T1,Vn1,Vs1} = ets_pat(T0, Vn0, Vs0), %Right to left! - {H1,Vn2,Vs2} = ets_pat(H0, Vn1, Vs1), - {[H1|T1],Vn2,Vs2}; -ets_pat(P, Vn0, Vs0) when is_tuple(P), size(P) >= 2 -> - {As,Vn1,Vs1} = ets_pat_arg(P, Vn0, Vs0, size(P), []), - {list_to_tuple([element(1, P)|As]),Vn1,Vs1}; -ets_pat(P, Vn, Vs) -> {P,Vn,Vs}. %Constant - -ets_pat_arg(_P, Vn, Vs, 1, As) -> {As,Vn,Vs}; -ets_pat_arg(P, Vn0, Vs0, I, As) -> - {A,Vn1,Vs1} = ets_pat(element(I, P), Vn0, Vs0), - ets_pat_arg(P, Vn1, Vs1, I-1, [A|As]). - -find(V, [{V,Ev}|_Vs]) -> {yes,Ev}; -find(V, [_P|Vs]) -> find(V, Vs); -find(_V, []) -> no. - -ets_var(1) -> '$1'; -ets_var(2) -> '$2'; -ets_var(3) -> '$3'; -ets_var(4) -> '$4'; -ets_var(5) -> '$5'; -ets_var(6) -> '$6'; -ets_var(7) -> '$7'; -ets_var(8) -> '$8'; -ets_var(9) -> '$9'; -ets_var(10) -> '$10'; -ets_var(11) -> '$11'. diff --git a/src/erlog_file.erl b/src/erlog_file.erl deleted file mode 100644 index 6e2f029..0000000 --- a/src/erlog_file.erl +++ /dev/null @@ -1,81 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_file.erl -%% Author : Robert Virding -%% Purpose : The Erlog file consulter. - --module(erlog_file). - --export([consult/2,reconsult/2]). - - -%% consult(File, Database) -> -%% {ok,NewDatabase} | {error,Error} | {erlog_error,Error}. -%% reconsult(File, Database) -> -%% {ok,NewDatabase} | {error,Error} | {erlog_error,Error}. -%% Load/reload an Erlog file into the interpreter. Reloading will -%% abolish old definitons of clauses. - -consult(File, Db0) -> - case erlog_io:read_file(File) of - {ok,Terms} -> - consult_terms(fun consult_assert/2, Db0, Terms); - Error -> Error - end. - -consult_assert(Term0, Db) -> - Term1 = erlog_dcg:expand_term(Term0), - {ok,erlog_int:assertz_clause(Term1, Db)}. - -reconsult(File, Db0) -> - case erlog_io:read_file(File) of - {ok,Terms} -> - case consult_terms(fun reconsult_assert/2, {Db0,[]}, Terms) of - {ok,{Db1,_Seen1}} -> {ok,Db1}; - Error -> Error - end; - Error -> Error - end. - -reconsult_assert(Term0, {Db0,Seen}) -> - Term1 = erlog_dcg:expand_term(Term0), - Func = functor(Term1), - case lists:member(Func, Seen) of - true -> - {ok,{erlog_int:assertz_clause(Term1, Db0), Seen}}; - false -> - Db1 = erlog_int:abolish_clauses(Func, Db0), - {ok,{erlog_int:assertz_clause(Term1, Db1), [Func|Seen]}} - end. - -%% consult_terms(InsertFun, Database, Terms) -> -%% {ok,NewDatabase} | {erlog_error,Error}. -%% Add terms to the database using InsertFun. Ignore directives and -%% queries. - -consult_terms(Ifun, Db, [{':-',_}|Ts]) -> - consult_terms(Ifun, Db, Ts); -consult_terms(Ifun, Db, [{'?-',_}|Ts]) -> - consult_terms(Ifun, Db, Ts); -consult_terms(Ifun, Db0, [T|Ts]) -> - case catch Ifun(T, Db0) of - {ok,Db1} -> consult_terms(Ifun, Db1, Ts); - {erlog_error,E,_Db1} -> {erlog_error,E}; - {erlog_error,E} -> {erlog_error,E} - end; -consult_terms(_Ifun, Db, []) -> {ok,Db}. - -functor({':-',H,_B}) -> erlog_int:functor(H); -functor(T) -> erlog_int:functor(T). diff --git a/src/erlog_int.erl b/src/erlog_int.erl deleted file mode 100644 index f91a99d..0000000 --- a/src/erlog_int.erl +++ /dev/null @@ -1,1315 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_int.erl -%% Author : Robert Virding -%% Purpose : Basic interpreter of a Prolog sub-set. -%% -%% This is the basic Prolog interpreter. -%% The internal data structures used are very direct and basic: -%% -%% Structures - {Functor,arg1, Arg2,...} where Functor is an atom -%% Variables - {Name} where Name is an atom or integer -%% Lists - Erlang lists -%% Atomic - Erlang constants -%% -%% There is no problem with the representation of variables as Prolog -%% functors of arity 0 are atoms. This representation is much easier -%% to test for, and create new variables with than using funny atom -%% names like '$1' (yuch!), and we need LOTS of variables. -%% -%% All information about the state of an evaluation is held in the -%% variables: -%% -%% [CurrentGoal,] NextGoal, ChoicePoints, Bindings, VarNum, Database -%% -%% Proving a goal succeeds when we have reached the end of the goal -%% list, i.e. NextGoal is empty (true). Proving goal fails when there -%% are no more choice points left to backtrack into. The evaluation -%% is completely flat as all back track information is held in -%% ChoicePoints. Choice points are added going forwards and removed -%% by backtracking and cuts. -%% -%% Internal goals all have the format {{Name},...} as this is an -%% illegal Erlog structure which can never be generated in (legal) -%% code. -%% -%% Proving a top-level goal will return: -%% -%% {succeed,ChoicePoints,Bindings,VarNum,Database} - the -%% goal succeeded and these are the -%% choicepoints/bindings/varnum/database to continue with. -%% -%% {fail,Database} - the goal failed and this is the current database. -%% -%% When a goal has succeeded back tracking is initiated by calling -%% fail(ChoicePoints, Database) which has the same return values as -%% proving the goal. -%% -%% When the interpreter detects an error it builds an error term -%% -%% {erlog_error,ErrorDescriptor,Database} -%% -%% and throws it. The ErrorDescriptor is a valid Erlog term. -%% -%% Database -%% -%% We use a dictionary for the database. All data for a procedure are -%% kept in the database with the functor as key. Interpreted clauses -%% are kept in a list, each clause has a unique (for that functor) -%% tag. Functions which traverse clauses, clause/retract/goals, get -%% the whole list to use. Any database operations can they be done -%% directly on the database. Retract uses the tag to remove the -%% correct clause. This preserves the logical database view. It is -%% possible to use ETS instead if a dictionary, define macro ETS, but -%% the logical database view makes it difficult to directly use ETS -%% efficiently. -%% -%% Interpreted Code -%% -%% Code, interpreted clause bodies, are not stored directly as Erlog -%% terms. Before being added to the database they are checked that -%% they are well-formed, control structures are recognised, cuts -%% augmented with status and sequences of conjunctions are converted -%% to lists. When code is used a new instance is made with fresh -%% variables, correct cut labels, and bodies directly linked to -%% following code to remove the need of later appending. -%% -%% The following functions convert code: -%% -%% well_form_body/4 - converts an Erlog term to database code body -%% format checking that it is well formed. -%% well_form_goal/4 - converts an Erlog term directly to a code body -%% checking that it is well formed. -%% unify_head/4 - unify a goal directly with head without creating a -%% new instance of the head. Saves creating local variables and -%% MANY bindings. This is a BIG WIN! -%% body_instance/5 - creates a new code body instance from the -%% database format. -%% term_instance/2/3 - creates a new instance of a term with new -%% variables. -%% body_term/3 - creates a copy of a body as a legal Erlog term. -%% -%% Choicepoints/Cuts -%% -%% Choicepoints and cuts are kept on the same stack/list. There are -%% different types of cps depending on their context. Failure pops -%% the first cp off the stack, passing over cuts and resumes -%% execution from that cp. A cut has a label and a flag indicating if -%% this is the last cut with this label. Cut steps over cps/cuts -%% until a cut the same label is reached and execution is resumed -%% with that stack. Unless this is the last cut with a label a new -%% cut is pushed on the stack. For efficiency some cps also act as -%% cuts. -%% -%% It is possible to reuse cut labels for different markers as long -%% the areas the cuts are valid don't overlap, though one may be -%% contained within the other, and the cuts correctly indicate when -%% they are the last cut. This is used for ->; and once/1 where we -%% KNOW the last cut of the internal section. -%% -%% It would be better if the cut marker was the actual cps/cut stack -%% to go back to but this would entail a more interactive -%% body_instance. - --module(erlog_int). - -%% Main execution functions. --export([prove_goal/2,prove_body/5,fail/2]). --export([unify_prove_body/7,unify_prove_body/9]). -%% Bindings, unification and dereferncing. --export([new_bindings/0,add_binding/3,make_vars/2]). --export([deref/2,deref_list/2,dderef/2,dderef_list/2,unify/3,functor/1]). -%% Creating term and body instances. --export([term_instance/2]). -%% Adding to database. --export([asserta_clause/2,assertz_clause/2,abolish_clauses/2]). --export([add_built_in/2,add_compiled_proc/4]). --export([new_db/0,built_in_db/0]). - -%% Error types. --export([erlog_error/1,erlog_error/2,type_error/2,type_error/3, - instantiation_error/0,instantiation_error/1,permission_error/4]). - -%%-compile(export_all). - --import(lists, [map/2,foldl/3]). - -%% Some standard type macros. - -%% The old is_constant/1 ? --define(IS_CONSTANT(T), (not (is_tuple(T) orelse is_list(T)))). - -%% -define(IS_ATOMIC(T), (is_atom(T) orelse is_number(T) orelse (T == []))). --define(IS_ATOMIC(T), (not (is_tuple(T) orelse (is_list(T) andalso T /= [])))). --define(IS_FUNCTOR(T), ((tuple_size(T) >= 2) andalso is_atom(element(1, T)))). - -%% Define the database to use. ONE of the follwing must be defined. - -%%-define(ETS,true). -%%-define(DB, orddict). --define(DB, dict). - -%% built_in_db() -> Database. -%% Create an initial clause database containing the built-in -%% predicates and predefined library predicates. - -built_in_db() -> - Db0 = new_db(), - %% First add the Erlang built-ins. - Db1 = foldl(fun (Head, Db) -> add_built_in(Head, Db) end, Db0, - [ - %% Logic and control. - {call,1}, - {',',2}, - {'!',0}, - {';',2}, - {fail,0}, - {'->',2}, - {'\\+',1}, - {once,1}, - {repeat,0}, - {true,0}, - %% Clause creation and destruction. - {abolish,1}, - {assert,1}, - {asserta,1}, - {assertz,1}, - {retract,1}, - {retractall,1}, - %% Clause retrieval and information. - {clause,2}, - {current_predicate,1}, - {predicate_property,2}, - %% All solutions - %% External interface - {ecall,2}, - %% Non-standard but useful - {display,1} - ]), - Db1. - -%% Define the choice point record --record(cp, {type,label,data,next,bs,vn}). --record(cut, {label,next}). - -%% prove_goal(Goal, Database) -> Succeed | Fail. -%% This is the main entry point into the interpreter. Check that -%% everything is consistent then prove the goal as a call. - -prove_goal(Goal0, Db) -> - %% put(erlog_cut, orddict:new()), - %% put(erlog_cps, orddict:new()), - %% put(erlog_var, orddict:new()), - %% Check term and build new instance of term with bindings. - {Goal1,Bs,Vn} = initial_goal(Goal0), - prove_body([{call,Goal1}], [], Bs, Vn, Db). - --define(FAIL(Bs, Cps, Db), - begin - put(erlog_cps, orddict:update_counter(length(Cps), 1, get(erlog_cps))), - put(erlog_var, orddict:update_counter(dict:size(Bs), 1, get(erlog_var))), - fail(Cps, Db) - end). --undef(FAIL). --define(FAIL(Bs, Cps, Db), fail(Cps, Db)). - -%% prove_goal(Goal, NextGoal, ChoicePoints, Bindings, VarNum, Database) -> -%% {succeed,ChoicePoints,NewBindings,NewVarNum,NewDatabase} | -%% {fail,NewDatabase}. -%% Prove one goal. We seldom return succeed here but usually go directly to -%% to NextGoal. -%% Handle built-in predicates here. RTFM for a description of the -%% built-ins. Hopefully we do the same. - -%% Logic and control. Conjunctions are handled in prove_body and true -%% has been compiled away. -prove_goal({call,G}, Next0, Cps, Bs, Vn, Db) -> - %% Only add cut CP to Cps if goal contains a cut. - Label = Vn, - case check_goal(G, Next0, Bs, Db, false, Label) of - {Next1,true} -> - %% Must increment Vn to avoid clashes!!! - Cut = #cut{label=Label}, - prove_body(Next1, [Cut|Cps], Bs, Vn+1, Db); - {Next1,false} -> prove_body(Next1, Cps, Bs, Vn+1, Db) - end; -prove_goal({{cut},Label,Last}, Next, Cps, Bs, Vn, Db) -> - %% Cut succeeds and trims back to cut ancestor. - cut(Label, Last, Next, Cps, Bs, Vn, Db); -prove_goal({{disj},R}, Next, Cps, Bs, Vn, Db) -> - %% There is no L here, it has already been prepended to Next. - Cp = #cp{type=disjunction,next=R,bs=Bs,vn=Vn}, - prove_body(Next, [Cp|Cps], Bs, Vn, Db); -prove_goal(fail, _Next, Cps, _Bs, _Vn, Db) -> ?FAIL(_Bs, Cps, Db); -prove_goal({{if_then},Label}, Next, Cps, Bs, Vn, Db) -> - %% We effetively implement ( C -> T ) with ( C, !, T ) but cuts in - %% C are local to C. - %% There is no ( C, !, T ) here, it has already been prepended to Next. - %%io:fwrite("PG(->): ~p\n", [{Next}]), - Cut = #cut{label=Label}, - prove_body(Next, [Cut|Cps], Bs, Vn, Db); -prove_goal({{if_then_else},Else,Label}, Next, Cps, Bs, Vn, Db) -> - %% Need to push a choicepoint to fail back to inside Cond and a cut - %% to cut back to before Then when Cond succeeds. #cp{type=if_then_else} - %% functions as both as is always removed whatever the outcome. - %% There is no ( C, !, T ) here, it has already been prepended to Next. - Cp = #cp{type=if_then_else,label=Label,next=Else,bs=Bs,vn=Vn}, - %%io:fwrite("PG(->;): ~p\n", [{Next,Else,[Cp|Cps]}]), - prove_body(Next, [Cp|Cps], Bs, Vn, Db); -prove_goal({'\\+',G}, Next0, Cps, Bs, Vn, Db) -> - %% We effectively implementing \+ G with ( G -> fail ; true ). - Label = Vn, - {Next1,_} = check_goal(G, [{{cut},Label,true},fail], Bs, Db, true, Label), - Cp = #cp{type=if_then_else,label=Label,next=Next0,bs=Bs,vn=Vn}, - %%io:fwrite("PG(\\+): ~p\n", [{G1,[Cp|Cps]]), - %% Must increment Vn to avoid clashes!!! - prove_body(Next1, [Cp|Cps], Bs, Vn+1, Db); -prove_goal({{once},Label}, Next, Cps, Bs, Vn, Db) -> - %% We effetively implement once(G) with ( G, ! ) but cuts in - %% G are local to G. - %% There is no ( G, ! ) here, it has already been prepended to Next. - Cut = #cut{label=Label}, - prove_body(Next, [Cut|Cps], Bs, Vn, Db); -prove_goal(repeat, Next, Cps, Bs, Vn, Db) -> - Cp = #cp{type=disjunction,next=[repeat|Next],bs=Bs,vn=Vn}, - prove_body(Next, [Cp|Cps], Bs, Vn, Db); -%% Clause creation and destruction. -prove_goal({abolish,Pi0}, Next, Cps, Bs, Vn, Db) -> - case dderef(Pi0, Bs) of - {'/',N,A} when is_atom(N), is_integer(A), A > 0 -> - prove_body(Next, Cps, Bs, Vn, abolish_clauses({N,A}, Db)); - Pi -> type_error(predicate_indicator, Pi, Db) - end; -prove_goal({assert,C0}, Next, Cps, Bs, Vn, Db) -> - C = dderef(C0, Bs), - prove_body(Next, Cps, Bs, Vn, assertz_clause(C, Db)); -prove_goal({asserta,C0}, Next, Cps, Bs, Vn, Db) -> - C = dderef(C0, Bs), - prove_body(Next, Cps, Bs, Vn, asserta_clause(C, Db)); -prove_goal({assertz,C0}, Next, Cps, Bs, Vn, Db) -> - C = dderef(C0, Bs), - prove_body(Next, Cps, Bs, Vn, assertz_clause(C, Db)); -prove_goal({retract,C0}, Next, Cps, Bs, Vn, Db) -> - C = dderef(C0, Bs), - prove_retract(C, Next, Cps, Bs, Vn, Db); -%% Clause retrieval and information -prove_goal({clause,H0,B}, Next, Cps, Bs, Vn, Db) -> - H1 = dderef(H0, Bs), - prove_clause(H1, B, Next, Cps, Bs, Vn, Db); -prove_goal({current_predicate,Pi0}, Next, Cps, Bs, Vn, Db) -> - Pi = dderef(Pi0, Bs), - prove_current_predicate(Pi, Next, Cps, Bs, Vn, Db); -prove_goal({predicate_property,H0,P}, Next, Cps, Bs, Vn, Db) -> - H = dderef(H0, Bs), - case catch get_procedure_type(functor(H), Db) of - built_in -> unify_prove_body(P, built_in, Next, Cps, Bs, Vn, Db); - compiled -> unify_prove_body(P, compiled, Next, Cps, Bs, Vn, Db); - interpreted -> unify_prove_body(P, interpreted, Next, Cps, Bs, Vn, Db); - undefined -> ?FAIL(Bs, Cps, Db); - {erlog_error,E} -> erlog_error(E, Db) - end; -%% External interface -prove_goal({ecall,C0,Val}, Next, Cps, Bs, Vn, Db) -> - %% Build the initial call. - %%io:fwrite("PG(ecall): ~p\n ~p\n ~p\n", [dderef(C0, Bs),Next,Cps]), - Efun = case dderef(C0, Bs) of - {':',M,F} when is_atom(M), is_atom(F) -> - fun () -> M:F() end; - {':',M,{F,A}} when is_atom(M), is_atom(F) -> - fun () -> M:F(A) end; - {':',M,{F,A1,A2}} when is_atom(M), is_atom(F) -> - fun () -> M:F(A1,A2) end; - {':',M,T} when is_atom(M), ?IS_FUNCTOR(T) -> - L = tuple_to_list(T), - fun () -> apply(M, hd(L), tl(L)) end; - Fun when is_function(Fun) -> Fun; - Other -> type_error(callable, Other, Db) - end, - prove_ecall(Efun, Val, Next, Cps, Bs, Vn, Db); -%% Non-standard but useful. -prove_goal({display,T}, Next, Cps, Bs, Vn, Db) -> - %% A very simple display procedure. - io:fwrite("~p\n", [dderef(T, Bs)]), - prove_body(Next, Cps, Bs, Vn, Db); -%% Now look up the database. -prove_goal(G, Next, Cps, Bs, Vn, Db) -> - %%io:fwrite("PG: ~p\n ~p\n ~p\n", [dderef(G, Bs),Next,Cps]), - case catch get_procedure(functor(G), Db) of - built_in -> erlog_bips:prove_goal(G, Next, Cps, Bs, Vn, Db); - {code,{Mod,Func}} -> Mod:Func(G, Next, Cps, Bs, Vn, Db); - {clauses,Cs} -> prove_goal_clauses(G, Cs, Next, Cps, Bs, Vn, Db); - undefined -> ?FAIL(Bs, Cps, Db); - %% Getting built_in here is an error! - {erlog_error,E} -> erlog_error(E, Db) %Fill in more error data - end. - -fail_disjunction(#cp{next=Next,bs=Bs,vn=Vn}, Cps, Db) -> - prove_body(Next, Cps, Bs, Vn, Db). - -fail_if_then_else(#cp{next=Next,bs=Bs,vn=Vn}, Cps, Db) -> - prove_body(Next, Cps, Bs, Vn, Db). - -%% fail(ChoicePoints, Database) -> {fail,Database}. -%% cut(Label, Last, Next, ChoicePoints, Bindings, VarNum, Database) -> void. -%% -%% The functions which manipulate the choice point stack. fail -%% backtracks to next choicepoint skipping cut labels cut steps -%% backwards over choice points until matching cut. - -fail([#cp{type=goal_clauses}=Cp|Cps], Db) -> - fail_goal_clauses(Cp, Cps, Db); -fail([#cp{type=disjunction}=Cp|Cps], Db) -> - fail_disjunction(Cp, Cps, Db); -fail([#cp{type=if_then_else}=Cp|Cps], Db) -> - fail_if_then_else(Cp, Cps, Db); -fail([#cp{type=clause}=Cp|Cps], Db) -> - fail_clause(Cp, Cps, Db); -fail([#cp{type=retract}=Cp|Cps], Db) -> - fail_retract(Cp, Cps, Db); -fail([#cp{type=current_predicate}=Cp|Cps], Db) -> - fail_current_predicate(Cp, Cps, Db); -fail([#cp{type=ecall}=Cp|Cps], Db) -> - fail_ecall(Cp, Cps, Db); -fail([#cp{type=compiled,data=F}=Cp|Cps], Db) -> - F(Cp, Cps, Db); -fail([#cut{}|Cps], Db) -> - fail(Cps, Db); %Fail over cut points. -fail([], Db) -> {fail,Db}. - -cut(Label, Last, Next, [#cut{label=Label}|Cps]=Cps0, Bs, Vn, Db) -> - if Last -> prove_body(Next, Cps, Bs, Vn, Db); - true -> prove_body(Next, Cps0, Bs, Vn, Db) - end; -cut(Label, Last, Next, [#cp{type=if_then_else,label=Label}|Cps]=Cps0, Bs, Vn, Db) -> - if Last -> prove_body(Next, Cps, Bs, Vn, Db); - true -> prove_body(Next, Cps0, Bs, Vn, Db) - end; -cut(Label, Last, Next, [#cp{type=goal_clauses,label=Label}=Cp|Cps], Bs, Vn, Db) -> - cut_goal_clauses(Last, Next, Cp, Cps, Bs, Vn, Db); -cut(Label, Last, Next, [_Cp|Cps], Bs, Vn, Db) -> - cut(Label, Last, Next, Cps, Bs, Vn, Db). - -%% cut(Label, Last, Next, Cps, Bs, Vn, Db) -> -%% cut(Label, Last, Next, Cps, Bs, Vn, Db, 1). - -%% cut(Label, Last, Next, [#cut{label=Label}|Cps]=Cps0, Bs, Vn, Db, Cn) -> -%% put(erlog_cut, orddict:update_counter(Cn, 1, get(erlog_cut))), -%% if Last -> prove_body(Next, Cps, Bs, Vn, Db); -%% true -> prove_body(Next, Cps0, Bs, Vn, Db) -%% end; -%% cut(Label, Last, Next, [#cp{type=if_then_else,label=Label}|Cps]=Cps0, Bs, Vn, Db, Cn) -> -%% put(erlog_cut, orddict:update_counter(Cn, 1, get(erlog_cut))), -%% if Last -> prove_body(Next, Cps, Bs, Vn, Db); -%% true -> prove_body(Next, Cps0, Bs, Vn, Db) -%% end; -%% cut(Label, Last, Next, [#cp{type=goal_clauses,label=Label}=Cp|Cps], Bs, Vn, Db, Cn) -> -%% put(erlog_cut, orddict:update_counter(Cn, 1, get(erlog_cut))), -%% cut_goal_clauses(Last, Next, Cp, Cps, Bs, Vn, Db); -%% cut(Label, Last, Next, [_Cp|Cps], Bs, Vn, Db, Cn) -> -%% cut(Label, Last, Next, Cps, Bs, Vn, Db, Cn+1). - -%% check_goal(Goal, Next, Bindings, Database, CutAfter, CutLabel) -> -%% {WellFormedBody,HasCut}. -%% Check to see that Goal is bound and ensure that it is well-formed. - -check_goal(G0, Next, Bs, Db, Cut, Label) -> - case dderef(G0, Bs) of - {_} -> instantiation_error(Db); %Must have something to call - G1 -> - case catch {ok,well_form_goal(G1, Next, Cut, Label)} of - {erlog_error,E} -> erlog_error(E, Db); - {ok,GC} -> GC %Body and cut - end - end. - -%% unify_prove_body(Term1, Term2, Next, ChoicePoints, Bindings, VarNum, Database) -> -%% void. -%% Unify Term1 = Term2, on success prove body Next else fail. - -unify_prove_body(T1, T2, Next, Cps, Bs0, Vn, Db) -> - case unify(T1, T2, Bs0) of - {succeed,Bs1} -> prove_body(Next, Cps, Bs1, Vn, Db); - fail -> ?FAIL(Bs0, Cps, Db) - end. - -%% unify_prove_body(A1, B1, A2, B2, Next, ChoicePoints, Bindings, VarNum, Database) -> -%% void. -%% Unify A1 = B1, A2 = B2, on success prove body Next else fail. - -unify_prove_body(A1, B1, A2, B2, Next, Cps, Bs0, Vn, Db) -> - case unify(A1, B1, Bs0) of - {succeed,Bs1} -> unify_prove_body(A2, B2, Next, Cps, Bs1, Vn, Db); - fail -> ?FAIL(Bs0, Cps, Db) - end. - -%% prove_ecall(Generator, Value, Next, ChoicePoints, Bindings, VarNum, Database) -> -%% void. -%% Call an external (Erlang) generator and handle return value, either -%% succeed or fail. - -prove_ecall(Efun, Val, Next, Cps, Bs, Vn, Db) -> - case Efun() of - {succeed,Ret,Cont} -> %Succeed and more choices - Cp = #cp{type=ecall,data={Cont,Val},next=Next,bs=Bs,vn=Vn}, - unify_prove_body(Val, Ret, Next, [Cp|Cps], Bs, Vn, Db); - {succeed_last,Ret} -> %Succeed but last choice - unify_prove_body(Val, Ret, Next, Cps, Bs, Vn, Db); - fail -> ?FAIL(Bs, Cps, Db) %No more - end. - -fail_ecall(#cp{data={Efun,Val},next=Next,bs=Bs,vn=Vn}, Cps, Db) -> - prove_ecall(Efun, Val, Next, Cps, Bs, Vn, Db). - -%% prove_clause(Head, Body, Next, ChoicePoints, Bindings, VarNum, DataBase) -> -%% void. -%% Unify clauses matching with functor from Head with both Head and Body. - -prove_clause(H, B, Next, Cps, Bs, Vn, Db) -> - Functor = functor(H), - case get_procedure(Functor, Db) of - {clauses,Cs} -> unify_clauses(H, B, Cs, Next, Cps, Bs, Vn, Db); - {code,_} -> - permission_error(access, private_procedure, pred_ind(Functor), Db); - built_in -> - permission_error(access, private_procedure, pred_ind(Functor), Db); - undefined -> ?FAIL(Bs, Cps, Db) - end. - -%% unify_clauses(Head, Body, Clauses, Next, ChoicePoints, Bindings, VarNum, Database) -> -%% void. -%% Try to unify Head and Body using Clauses which all have the same functor. - -unify_clauses(Ch, Cb, [C], Next, Cps, Bs0, Vn0, Db) -> - %% No choice point on last clause - case unify_clause(Ch, Cb, C, Bs0, Vn0) of - {succeed,Bs1,Vn1} -> prove_body(Next, Cps, Bs1, Vn1, Db); - fail -> ?FAIL(Bs0, Cps, Db) - end; -unify_clauses(Ch, Cb, [C|Cs], Next, Cps, Bs0, Vn0, Db) -> - case unify_clause(Ch, Cb, C, Bs0, Vn0) of - {succeed,Bs1,Vn1} -> - Cp = #cp{type=clause,data={Ch,Cb,Cs},next=Next,bs=Bs0,vn=Vn0}, - prove_body(Next, [Cp|Cps], Bs1, Vn1, Db); - fail -> unify_clauses(Ch, Cb, Cs, Next, Cps, Bs0, Vn0, Db) - end; -unify_clauses(_Ch, _Cb, [], _Next, Cps,_Bs, _Vn, Db) -> ?FAIL(_Bs, Cps, Db). - -unify_clause(Ch, Cb, {_Tag,H0,{B0,_}}, Bs0, Vn0) -> - {H1,Rs1,Vn1} = term_instance(H0, Vn0), %Unique vars on head first - case unify(Ch, H1, Bs0) of - {succeed,Bs1} -> - {B1,_Rs2,Vn2} = body_term(B0, Rs1, Vn1), %Now we need the rest - case unify(Cb, B1, Bs1) of - {succeed,Bs2} -> {succeed,Bs2,Vn2}; - fail -> fail - end; - fail -> fail - end. - -fail_clause(#cp{data={Ch,Cb,Cs},next=Next,bs=Bs,vn=Vn}, Cps, Db) -> - unify_clauses(Ch, Cb, Cs, Next, Cps, Bs, Vn, Db). - -%% prove_current_predicate(PredInd, Next, ChoicePoints, Bindings, VarNum, DataBase) -> -%% void. -%% Match functors of existing user (interpreted) predicate with PredInd. - -prove_current_predicate(Pi, Next, Cps, Bs, Vn, Db) -> - case Pi of - {'/',_,_} -> ok; - {_} -> ok; - Other -> type_error(predicate_indicator, Other) - end, - Fs = get_interp_functors(Db), - prove_predicates(Pi, Fs, Next, Cps, Bs, Vn, Db). - -prove_predicates(Pi, [F|Fs], Next, Cps, Bs, Vn, Db) -> - Cp = #cp{type=current_predicate,data={Pi,Fs},next=Next,bs=Bs,vn=Vn}, - unify_prove_body(Pi, pred_ind(F), Next, [Cp|Cps], Bs, Vn, Db); -prove_predicates(_Pi, [], _Next, Cps, _Bs, _Vn, Db) -> ?FAIL(_Bs, Cps, Db). - -fail_current_predicate(#cp{data={Pi,Fs},next=Next,bs=Bs,vn=Vn}, Cps, Db) -> - prove_predicates(Pi, Fs, Next, Cps, Bs, Vn, Db). - -%% prove_goal_clauses(Goal, Clauses, Next, ChoicePoints, Bindings, VarNum, Database) -> -%% void. -%% Try to prove Goal using Clauses which all have the same functor. - -prove_goal_clauses(G, [C], Next, Cps, Bs, Vn, Db) -> - %% Must be smart here and test whether we need to add a cut point. - %% C has the structure {Tag,Head,{Body,BodyHasCut}}. - case element(2, element(3, C)) of - true -> - Cut = #cut{label=Vn}, - prove_goal_clause(G, C, Next, [Cut|Cps], Bs, Vn, Db); - false -> - prove_goal_clause(G, C, Next, Cps, Bs, Vn, Db) - end; - %% prove_goal_clause(G, C, Next, Cps, Bs, Vn, Db); -prove_goal_clauses(G, [C|Cs], Next, Cps, Bs, Vn, Db) -> - Cp = #cp{type=goal_clauses,label=Vn,data={G,Cs},next=Next,bs=Bs,vn=Vn}, - prove_goal_clause(G, C, Next, [Cp|Cps], Bs, Vn, Db); -prove_goal_clauses(_G, [], _Next, Cps,_Bs, _Vn, Db) -> ?FAIL(_Bs, Cps ,Db). - -prove_goal_clause(G, {_Tag,H0,{B0,_}}, Next, Cps, Bs0, Vn0, Db) -> - %% io:fwrite("PGC1: ~p\n", [{G,H0,B0}]), - Label = Vn0, - case unify_head(G, H0, Bs0, Vn0+1) of - {succeed,Rs0,Bs1,Vn1} -> - %% io:fwrite("PGC2: ~p\n", [{Rs0}]), - {B1,_Rs2,Vn2} = body_instance(B0, Next, Rs0, Vn1, Label), - %% io:fwrite("PGC3: ~p\n", [{B1,Next,Cps}]), - prove_body(B1, Cps, Bs1, Vn2, Db); - fail -> ?FAIL(Bs0, Cps, Db) - end. - -fail_goal_clauses(#cp{data={G,Cs},next=Next,bs=Bs,vn=Vn}, Cps, Db) -> - prove_goal_clauses(G, Cs, Next, Cps, Bs, Vn, Db). - -%% cut_goal_clauses(Last, Next, Cp, Cps, Bs, Vn, Db). - -cut_goal_clauses(true, Next, #cp{label=_}, Cps, Bs, Vn, Db) -> - %% Just remove the choice point completely and continue. - prove_body(Next, Cps, Bs, Vn, Db); -cut_goal_clauses(false, Next, #cp{label=L}, Cps, Bs, Vn, Db) -> - %% Replace choice point with cut point then continue. - Cut = #cut{label=L}, - prove_body(Next, [Cut|Cps], Bs, Vn, Db). - -%% prove_retract(Clause, Next, ChoicePoints, Bindings, VarNum, Database) -> -%% void. -%% Retract clauses in database matching Clause. - -prove_retract({':-',H,B}, Next, Cps, Bs, Vn, Db) -> - prove_retract(H, B, Next, Cps, Bs, Vn, Db); -prove_retract(H, Next, Cps, Bs, Vn, Db) -> - prove_retract(H, true, Next, Cps, Bs, Vn, Db). - -prove_retract(H, B, Next, Cps, Bs, Vn, Db) -> - Functor = functor(H), - case get_procedure(Functor, Db) of - {clauses,Cs} -> retract_clauses(H, B, Cs, Next, Cps, Bs, Vn, Db); - {code,_} -> - permission_error(modify, static_procedure, pred_ind(Functor), Db); - built_in -> - permission_error(modify, static_procedure, pred_ind(Functor), Db); - undefined -> ?FAIL(Bs, Cps, Db) - end. - -%% retract_clauses(Head, Body, Clauses, Next, ChoicePoints, Bindings, VarNum, Database) -> -%% void. -%% Try to retract Head and Body using Clauses which all have the same functor. - -retract_clauses(Ch, Cb, [C|Cs], Next, Cps, Bs0, Vn0, Db0) -> - case unify_clause(Ch, Cb, C, Bs0, Vn0) of - {succeed,Bs1,Vn1} -> - %% We have found a right clause so now retract it. - Db1 = retract_clause(functor(Ch), element(1, C), Db0), - Cp = #cp{type=retract,data={Ch,Cb,Cs},next=Next,bs=Bs0,vn=Vn0}, - prove_body(Next, [Cp|Cps], Bs1, Vn1, Db1); - fail -> retract_clauses(Ch, Cb, Cs, Next, Cps, Bs0, Vn0, Db0) - end; -retract_clauses(_Ch, _Cb, [], _Next, Cps, _Bs, _Vn, Db) -> ?FAIL(_Bs, Cps, Db). - -fail_retract(#cp{data={Ch,Cb,Cs},next=Next,bs=Bs,vn=Vn}, Cps, Db) -> - retract_clauses(Ch, Cb, Cs, Next, Cps, Bs, Vn, Db). - -%% prove_body(Body, ChoicePoints, Bindings, VarNum, Database) -> -%% {succeed,ChoicePoints,NewBindings,NewVarNum,NewDatabase}. -%% Prove the goals in a body. Remove the first goal and try to prove -%% it. Return when there are no more goals. This is how proving a -%% goal/body succeeds. - -prove_body([G|Gs], Cps, Bs0, Vn0, Db0) -> - %%io:fwrite("PB: ~p\n", [{G,Gs,Cps}]), - prove_goal(G, Gs, Cps, Bs0, Vn0, Db0); -prove_body([], Cps, Bs, Vn, Db) -> - %%io:fwrite("Cps: ~p\nCut: ~p\nVar: ~p\nVar: ~p\n", - %% [get(erlog_cps),get(erlog_cut),get(erlog_var),dict:size(Bs)]), - %%io:fwrite("PB: ~p\n", [Cps]), - {succeed,Cps,Bs,Vn,Db}. %No more body - -%% unify(Term, Term, Bindings) -> {succeed,NewBindings} | fail. -%% Unify two terms with a set of bindings. - -unify(T10, T20, Bs0) -> - case {deref(T10, Bs0),deref(T20, Bs0)} of - {T1,T2} when ?IS_CONSTANT(T1), T1 == T2 -> - {succeed,Bs0}; - {{V},{V}} -> {succeed,Bs0}; - {{_}=Var,T2} -> {succeed,add_binding(Var, T2, Bs0)}; - {T1,{_}=Var} -> {succeed,add_binding(Var, T1, Bs0)}; - {[H1|T1],[H2|T2]} -> - case unify(H1, H2, Bs0) of - {succeed,Bs1} -> unify(T1, T2, Bs1); - fail -> fail - end; - {[],[]} -> {succeed,Bs0}; - {T1,T2} when tuple_size(T1) == tuple_size(T2), - element(1, T1) == element(1, T2) -> - unify_args(T1, T2, Bs0, 2, tuple_size(T1)); - _Other -> fail - end. - -unify_args(_, _, Bs, I, S) when I > S -> {succeed,Bs}; -unify_args(S1, S2, Bs0, I, S) -> - case unify(element(I, S1), element(I, S2), Bs0) of - {succeed,Bs1} -> unify_args(S1, S2, Bs1, I+1, S); - fail -> fail - end. - -%% make_vars(Count, VarNum) -> [Var]. -%% Make a list of new variables starting at VarNum. - -make_vars(0, _) -> []; -make_vars(I, Vn) -> - [{Vn}|make_vars(I-1, Vn+1)]. - -%% Errors -%% To keep dialyzer quiet. --spec type_error(_, _) -> no_return(). --spec type_error(_, _, _) -> no_return(). --spec instantiation_error() -> no_return(). --spec instantiation_error(_) -> no_return(). --spec permission_error(_, _, _, _) -> no_return(). --spec erlog_error(_) -> no_return(). --spec erlog_error(_, _) -> no_return(). - -type_error(Type, Value, Db) -> erlog_error({type_error,Type,Value}, Db). -type_error(Type, Value) -> erlog_error({type_error,Type,Value}). - -instantiation_error(Db) -> erlog_error(instantiation_error, Db). -instantiation_error() -> erlog_error(instantiation_error). - -permission_error(Op, Type, Value, Db) -> - erlog_error({permission_error,Op,Type,Value}, Db). - -erlog_error(E, Db) -> throw({erlog_error,E,Db}). -erlog_error(E) -> throw({erlog_error,E}). - --ifdef(DB). -%% Database -%% The database is a dict where the key is the functor pair {Name,Arity}. -%% The value is: built_in | -%% {clauses,NextTag,[{Tag,Head,Body}]} | -%% {code,{Module,Function}}. -%% Built-ins are defined by the system and cannot manipulated by user -%% code. -%% We are a little paranoid here and do our best to ensure consistency -%% in the database by checking input arguments even if we know they -%% come from "good" code. - -new_db() -> ?DB:new(). - -%% add_built_in(Functor, Database) -> NewDatabase. -%% Add Functor as a built-in in the database. - -add_built_in(Functor, Db) -> - ?DB:store(Functor, built_in, Db). - -%% add_compiled_proc(Functor, Module, Function, Database) -> NewDatabase. -%% Add Functor as a compiled procedure with code in Module:Function. No -%% checking. - -add_compiled_proc(Functor, M, F, Db) -> - ?DB:update(Functor, - fun (built_in) -> - permission_error(modify, static_procedure, pred_ind(Functor), Db); - (_) -> {code,{M,F}} - end, {code,{M,F}}, Db). - -%% assertz_clause(Clause, Database) -> NewDatabase. -%% assertz_clause(Head, Body, Database) -> NewDatabase. -%% Assert a clause into the database first checking that it is well -%% formed. - -assertz_clause({':-',H,B}, Db) -> assertz_clause(H, B, Db); -assertz_clause(H, Db) -> assertz_clause(H, true, Db). - -assertz_clause(Head, Body0, Db) -> - {Functor,Body} = case catch {ok,functor(Head), - well_form_body(Body0, false, sture)} of - {erlog_error,E} -> erlog_error(E, Db); - {ok,F,B} -> {F,B} - end, - ?DB:update(Functor, - fun (built_in) -> - permission_error(modify, static_procedure, pred_ind(Functor), Db); - ({code,_}) -> - permission_error(modify, static_procedure, pred_ind(Functor), Db); - ({clauses,T,Cs}) -> {clauses,T+1,Cs ++ [{T,Head,Body}]} - end, {clauses,1,[{0,Head,Body}]}, Db). - -%% asserta_clause(Clause, Database) -> NewDatabase. -%% asserta_clause(Head, Body, Database) -> NewDatabase. -%% Assert a clause into the database first checking that it is well -%% formed. - -asserta_clause({':-',H,B}, Db) -> asserta_clause(H, B, Db); -asserta_clause(H, Db) -> asserta_clause(H, true, Db). - -asserta_clause(Head, Body0, Db) -> - {Functor,Body} = case catch {ok,functor(Head), - well_form_body(Body0, false, sture)} of - {erlog_error,E} -> erlog_error(E, Db); - {ok,F,B} -> {F,B} - end, - ?DB:update(Functor, - fun (built_in) -> - permission_error(modify, static_procedure, pred_ind(Functor), Db); - ({code,_}) -> - permission_error(modify, static_procedure, pred_ind(Functor), Db); - ({clauses,T,Cs}) -> {clauses,T+1,[{T,Head,Body}|Cs]} - end, {clauses,1,[{0,Head,Body}]}, Db). - -%% retract_clause(Functor, ClauseTag, Database) -> NewDatabase. -%% Retract (remove) the clause with tag ClauseTag from the list of -%% clauses of Functor. - -retract_clause(F, Ct, Db) -> - case ?DB:find(F, Db) of - {ok,built_in} -> - permission_error(modify, static_procedure, pred_ind(F), Db); - {ok,{code,_}} -> - permission_error(modify, static_procedure, pred_ind(F), Db); - {ok,{clauses,Nt,Cs}} -> - ?DB:store(F, {clauses,Nt,lists:keydelete(Ct, 1, Cs)}, Db); - error -> Db %Do nothing - end. - -%% abolish_clauses(Functor, Database) -> NewDatabase. - -abolish_clauses(Func, Db) -> - case ?DB:find(Func, Db) of - {ok,built_in} -> - permission_error(modify, static_procedure, pred_ind(Func), Db); - {ok,{code,_}} -> ?DB:erase(Func, Db); - {ok,{clauses,_,_}} -> ?DB:erase(Func, Db); - error -> Db %Do nothing - end. - -%% get_procedure(Functor, Database) -> -%% built_in | {code,{Mod,Func}} | {clauses,[Clause]} | undefined. -%% Return the procedure type and data for a functor. - -get_procedure(Func, Db) -> - case ?DB:find(Func, Db) of - {ok,built_in} -> built_in; %A built-in - {ok,{code,{_M,_F}}=P} -> P; %Compiled (perhaps someday) - {ok,{clauses,_T,Cs}} -> {clauses,Cs}; %Interpreted clauses - error -> undefined %Undefined - end. - -%% get_procedure_type(Functor, Database) -> -%% built_in | compiled | interpreted | undefined. -%% Return the procedure type for a functor. - -get_procedure_type(Func, Db) -> - case ?DB:find(Func, Db) of - {ok,built_in} -> built_in; %A built-in - {ok,{code,_}} -> compiled; %Compiled (perhaps someday) - {ok,{clauses,_,_}} -> interpreted; %Interpreted clauses - error -> undefined %Undefined - end. - -%% get_interp_functors(Database) -> [Functor]. - -get_interp_functors(Db) -> - ?DB:fold(fun (_Func, built_in, Fs) -> Fs; - (Func, {code,_}, Fs) -> [Func|Fs]; - (Func, {clauses,_,_}, Fs) -> [Func|Fs] - end, [], Db). --endif. - --ifdef(ETS). -%% The database is an ets table where the key is the functor pair {Name,Arity}. -%% The value is: {Functor,built_in} | -%% {Functor,clauses,NextTag,[{Tag,Head,Body}]} | -%% {Functor,code,{Module,Function}}. -%% Built-ins are defined by the system and cannot manipulated by user -%% code. -%% We are a little paranoid here and do our best to ensure consistency -%% in the database by checking input arguments even if we know they -%% come from "good" code. - -new_db() -> ets:new(erlog_database, [set,protected,{keypos,1}]). - -%% add_built_in(Functor, Database) -> NewDatabase. -%% Add Functor as a built-in in the database. - -add_built_in(Functor, Db) -> - ets:insert(Db, {Functor,built_in}), - Db. - -%% add_compiled_proc(Functor, Module, Function, Database) -> NewDatabase. -%% Add Functor as a compiled procedure with code in Module:Function. No -%% checking. - -add_compiled_proc(Functor, M, F, Db) -> - case ets:lookup(Db, Functor) of - [{_,built_in}] -> - permission_error(modify, static_procedure, pred_ind(Functor), Db); - [_] -> ets:insert(Db, {Functor,code,{M,F}}); - [] -> ets:insert(Db, {Functor,code,{M,F}}) - end, - Db. - -%% assertz_clause(Clause, Database) -> NewDatabase. -%% assertz_clause(Head, Body, Database) -> NewDatabase. -%% Assert a clause into the database first checking that it is well -%% formed. - -assertz_clause({':-',H,B}, Db) -> assertz_clause(H, B, Db); -assertz_clause(H, Db) -> assertz_clause(H, true, Db). - -assertz_clause(Head, Body0, Db) -> - {Functor,Body} = case catch {ok,functor(Head), - well_form_body(Body0, false, sture)} of - {erlog_error,E} -> erlog_error(E, Db); - {ok,F,B} -> {F,B} - end, - case ets:lookup(Db, Functor) of - [{_,built_in}] -> permission_error(pred_ind(Functor), Db); - [{_,code,_}] -> permission_error(pred_ind(Functor), Db); - [{_,clauses,Tag,Cs}] -> - ets:insert(Db, {Functor,clauses,Tag+1,Cs ++ [{Tag,Head,Body}]}); - [] -> ets:insert(Db, {Functor,clauses,1,[{0,Head,Body}]}) - end, - Db. - -%% asserta_clause(Clause, Database) -> NewDatabase. -%% asserta_clause(Head, Body, Database) -> NewDatabase. -%% Assert a clause into the database first checking that it is well -%% formed. - -asserta_clause({':-',H,B}, Db) -> asserta_clause(H, B, Db); -asserta_clause(H, Db) -> asserta_clause(H, true, Db). - -asserta_clause(Head, Body0, Db) -> - {Functor,Body} = case catch {ok,functor(Head), - well_form_body(Body0, false, sture)} of - {erlog_error,E} -> erlog_error(E, Db); - {ok,F,B} -> {F,B} - end, - case ets:lookup(Db, Functor) of - [{_,built_in}] -> permission_error(pred_ind(Functor), Db); - [{_,code,_}] -> permission_error(pred_ind(Functor), Db); - [{_,clauses,Tag,Cs}] -> - ets:insert(Db, {Functor,clauses,Tag+1,[{Tag,Head,Body}|Cs]}); - [] -> ets:insert(Db, {Functor,clauses,1,[{0,Head,Body}]}) - end, - Db. - -%% retract_clause(Functor, ClauseTag, Database) -> NewDatabase. -%% Retract (remove) the clause with tag ClauseTag from the list of -%% clauses of Functor. - -retract_clause(F, Ct, Db) -> - case ets:lookup(Db, F) of - [{_,built_in}] -> - permission_error(modify, static_procedure, pred_ind(F), Db); - [{_,code,_}] -> - permission_error(modify, static_procedure, pred_ind(F), Db); - [{_,clauses,Nt,Cs}] -> - ets:insert(Db, {F,clauses,Nt,lists:keydelete(Ct, 1, Cs)}); - [] -> ok %Do nothing - end, - Db. - -%% abolish_clauses(Functor, Database) -> NewDatabase. - -abolish_clauses(Func, Db) -> - case ets:lookup(Db, Func) of - [{_,built_in}] -> - permission_error(modify, static_procedure, pred_ind(F), Db); - [{_,code,_}] -> ets:delete(Db, Func); - [{_,clauses,_,_}] -> ets:delete(Db, Func); - [] -> ok %Do nothing - end, - Db. - -%% get_procedure(Functor, Database) -> -%% built_in | {code,{Mod,Func}} | {clauses,[Clause]} | undefined. -%% Return the procedure type and data for a functor. - -get_procedure(Func, Db) -> - case ets:lookup(Db, Func) of - [{_,built_in}] -> built_in; - [{_,code,C}] -> {code,C}; - [{_,clauses,_,Cs}] -> {clauses,Cs}; - [] -> undefined - end. - -%% get_procedure_type(Functor, Database) -> -%% built_in | compiled | interpreted | undefined. -%% Return the procedure type for a functor. - -get_procedure_type(Func, Db) -> - case ets:lookup(Db, Func) of - [{_,built_in}] -> built_in; %A built-in - [{_,code,C}] -> compiled; %Compiled (perhaps someday) - [{_,clauses,_,Cs}] -> interpreted; %Interpreted clauses - [] -> undefined %Undefined - end. - -%% get_interp_functors(Database) -> [Functor]. - -get_interp_functors(Db) -> - ets:foldl(fun ({_,built_in}, Fs) -> Fs; - ({Func,code,_}, Fs) -> [Func|Fs]; - ({Func,clauses,_,_}, Fs) -> [Func|Fs] - end, [], Db). --endif. - -%% functor(Goal) -> {Name,Arity}. - -functor(T) when ?IS_FUNCTOR(T) -> - {element(1, T),tuple_size(T)-1}; -functor(T) when is_atom(T) -> {T,0}; -functor(T) -> type_error(callable, T). - -%% well_form_body(Body, HasCutAfter, CutLabel) -> {Body,HasCut}. -%% well_form_body(Body, Tail, HasCutAfter, CutLabel) -> {Body,HasCut}. -%% Check that Body is well-formed, flatten conjunctions, fix cuts and -%% add explicit call to top-level variables. - -well_form_body(Body, Cut, Label) -> well_form_body(Body, [], Cut, Label). - -well_form_body({',',L,R}, Tail0, Cut0, Label) -> - {Tail1,Cut1} = well_form_body(R, Tail0, Cut0, Label), - well_form_body(L, Tail1, Cut1, Label); -well_form_body({';',{'->',C0,T0},E0}, Tail, Cut0, Label) -> - {T1,Tc} = well_form_body(T0, Cut0, Label), - {E1,Ec} = well_form_body(E0, Cut0, Label), - %% N.B. an extra cut will be added at run-time! - {C1,_} = well_form_body(C0, true, Label), - {[{{if_then_else},C1,T1,E1,Label}|Tail],Tc or Ec}; -well_form_body({';',L0,R0}, Tail, Cut0, Label) -> - {L1,Lc} = well_form_body(L0, Cut0, Label), - {R1,Rc} = well_form_body(R0, Cut0, Label), - {[{{disj},L1,R1}|Tail],Lc or Rc}; -well_form_body({'->',C0,T0}, Tail, Cut0, Label) -> - {T1,Cut1} = well_form_body(T0, Cut0, Label), - %% N.B. an extra cut will be added at run-time! - {C1,_} = well_form_body(C0, true, Label), - {[{{if_then},C1,T1,Label}|Tail],Cut1}; -well_form_body({once,G}, Tail, Cut, Label) -> - %% N.B. an extra cut is added at run-time! - {G1,_} = well_form_body(G, true, Label), - {[{{once},G1,Label}|Tail],Cut}; -well_form_body({V}, Tail, Cut, _Label) -> - {[{call,{V}}|Tail],Cut}; -well_form_body(true, Tail, Cut, _Label) -> {Tail,Cut}; %No-op -well_form_body(fail, _Tail, _Cut, _Label) -> {[fail],false}; %No further -well_form_body('!', Tail, Cut, Label) -> - {[{{cut},Label,not Cut}|Tail],true}; -well_form_body(Goal, Tail, Cut, _Label) -> - functor(Goal), %Check goal - {[Goal|Tail],Cut}. - -%% well_form_goal(Goal, Tail, HasCutAfter, CutLabel) -> {Body,HasCut}. -%% Check that Goal is well-formed, flatten conjunctions, fix cuts and -%% add explicit call to top-level variables. - -well_form_goal({',',L,R}, Tail0, Cut0, Label) -> - {Tail1,Cut1} = well_form_goal(R, Tail0, Cut0, Label), - well_form_goal(L, Tail1, Cut1, Label); -well_form_goal({';',{'->',C0,T0},E0}, Tail, Cut0, Label) -> - {T1,Tc} = well_form_goal(T0, Tail, Cut0, Label), - {C1,_} = well_form_goal(C0, [{{cut},Label,true}|T1], true, Label), - {E1,Ec} = well_form_goal(E0, Tail, Cut0, Label), - {[{{if_then_else},E1,Label}|C1],Tc or Ec}; -well_form_goal({';',L0,R0}, Tail, Cut0, Label) -> - {L1,Lc} = well_form_goal(L0, Tail, Cut0, Label), - {R1,Rc} = well_form_goal(R0, Tail, Cut0, Label), - {[{{disj},R1}|L1],Lc or Rc}; -well_form_goal({'->',C0,T0}, Tail, Cut0, Label) -> - {T1,Cut1} = well_form_goal(T0, Tail, Cut0, Label), - %% N.B. an extra cut will be added at run-time! - {C1,_} = well_form_goal(C0, [{{cut},Label,true}|T1], true, Label), - {[{{if_then},Label}|C1],Cut1}; -well_form_goal({once,G}, Tail, Cut, Label) -> - {G1,_} = well_form_goal(G, [{{cut},Label,true}|Tail], true, Label), - {[{{once},Label}|G1],Cut}; -well_form_goal({V}, Tail, Cut, _Label) -> - {[{call,{V}}|Tail],Cut}; -well_form_goal(true, Tail, Cut, _Label) -> {Tail,Cut}; %No-op -well_form_goal(fail, _Tail, _Cut, _Label) -> {[fail],false}; %No further -well_form_goal('!', Tail, Cut, Label) -> - {[{{cut},Label,not Cut}|Tail],true}; -well_form_goal(Goal, Tail, Cut, _Label) -> - functor(Goal), %Check goal - {[Goal|Tail],Cut}. - -%% term_instance(Term, VarNum) -> {Term,NewRepls,NewVarNum}. -%% term_instance(Term, Repls, VarNum) -> {Term,NewRepls,NewVarNum}. -%% Generate a copy of a term with new, fresh unused variables. No -%% bindings from original variables to new variables. It can handle -%% replacing integer variables with overlapping integer ranges. Don't -%% check Term as it should already be checked. Use orddict as there -%% will seldom be many variables and it it fast to setup. - -term_instance(A, Vn) -> term_instance(A, orddict:new(), Vn). - -term_instance([], Rs, Vn) -> {[],Rs,Vn}; -term_instance([H0|T0], Rs0, Vn0) -> - {H,Rs1,Vn1} = term_instance(H0, Rs0, Vn0), - {T,Rs2,Vn2} = term_instance(T0, Rs1, Vn1), - {[H|T],Rs2,Vn2}; -term_instance({'_'}, Rs, Vn) -> {{Vn},Rs,Vn+1}; %Unique variable -term_instance({V0}, Rs0, Vn0) -> %Other variables - case orddict:find(V0, Rs0) of - {ok,V1} -> {V1,Rs0,Vn0}; - error -> - V1 = {Vn0}, - {V1,orddict:store(V0, V1, Rs0),Vn0+1} - end; -%% Special case some smaller structures. -term_instance({Atom,Arg}, Rs0, Vn0) -> - {CopyArg,Rs1,Vn1} = term_instance(Arg, Rs0, Vn0), - {{Atom,CopyArg},Rs1,Vn1}; -term_instance({Atom,A1,A2}, Rs0, Vn0) -> - {CopyA1,Rs1,Vn1} = term_instance(A1, Rs0, Vn0), - {CopyA2,Rs2,Vn2} = term_instance(A2, Rs1, Vn1), - {{Atom,CopyA1,CopyA2},Rs2,Vn2}; -term_instance(T, Rs0, Vn0) when is_tuple(T) -> - As0 = tl(tuple_to_list(T)), - {As1,Rs1,Vn1} = term_instance(As0, Rs0, Vn0), - {list_to_tuple([element(1, T)|As1]),Rs1,Vn1}; -term_instance(A, Rs, Vn) -> {A,Rs,Vn}. %Constant - -%% unify_head(Goal, Head, Bindings, VarNum) -> -%% {succeed,Repls,NewBindings,NewVarNum} | fail -%% Unify a goal with a head without creating an instance of the -%% head. This saves us creating many variables which are local to the -%% clause and saves many variable bindings. - -unify_head(Goal, Head, Bs, Vn) -> - unify_head(deref(Goal, Bs), Head, orddict:new(), Bs, Vn). - -unify_head(G, H, Rs, Bs, Vn) when ?IS_CONSTANT(G), G == H -> - {succeed,Rs,Bs,Vn}; -unify_head(_T, {'_'}, Rs, Bs, Vn) -> {succeed,Rs,Bs,Vn}; -unify_head(T, {V0}, Rs, Bs0, Vn) -> - %% Now for the tricky bit! - case orddict:find(V0, Rs) of - {ok,V1} -> %Already have a replacement - case unify(T, V1, Bs0) of - {succeed,Bs1} -> {succeed,Rs,Bs1,Vn}; - fail -> fail - end; - error -> %Add a replacement - {succeed,orddict:store(V0, T, Rs),Bs0,Vn} - end; -unify_head({_}=Var, H0, Rs0, Bs, Vn0) -> - %% Must have an instance here. - {H1,Rs1,Vn1} = term_instance(H0, Rs0, Vn0), - {succeed,Rs1,add_binding(Var, H1, Bs),Vn1}; -unify_head([GH|GT], [HH|HT], Rs0, Bs0, Vn0) -> - case unify_head(deref(GH, Bs0), HH, Rs0, Bs0, Vn0) of - {succeed,Rs1,Bs1,Vn1} -> unify_head(deref(GT, Bs1), HT, Rs1, Bs1, Vn1); - fail -> fail - end; -unify_head([], [], Rs, Bs, Vn) -> {succeed,Rs,Bs,Vn}; -unify_head(G, H, Rs, Bs, Vn) when tuple_size(G) == tuple_size(H), - element(1, G) == element(1, H) -> - unify_head_args(G, H, Rs, Bs, Vn, 2, tuple_size(G)); -unify_head(_G, _H, _Rs, _Bs, _Vn) -> fail. - -unify_head_args(_G, _H, Rs, Bs, Vn, I, S) when I > S -> - {succeed,Rs,Bs,Vn}; -unify_head_args(G, H, Rs0, Bs0, Vn0, I, S) -> - case unify_head(deref(element(I, G), Bs0), element(I, H), Rs0, Bs0, Vn0) of - {succeed,Rs1,Bs1,Vn1} -> unify_head_args(G, H, Rs1, Bs1, Vn1, I+1, S); - fail -> fail - end. - -%% body_instance(Body, Tail, Repls, VarNum, Label) -> -%% {Body,NewRepls,NewVarNum}. -%% Generate a copy of a body in a form ready to be interpreted. No -%% bindings from original variables to new variables. It can handle -%% replacing integer variables with overlapping integer ranges. Don't -%% check Term as it should already be checked. Use term_instance to -%% handle goals. N.B. We have to be VERY careful never to go into the -%% original tail as this will cause havoc. - -body_instance([{{cut}=Cut,_,Last}|Gs0], Tail, Rs0, Vn0, Label) -> - {Gs1,Rs1,Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), - {[{Cut,Label,Last}|Gs1],Rs1,Vn1}; -body_instance([{{disj}=Disj,L0,R0}|Gs0], Tail, Rs0, Vn0, Label) -> - {Gs1,Rs1,Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), - %% Append Gs1 directly to L and R. - {L1,Rs2,Vn2} = body_instance(L0, Gs1, Rs1, Vn1, Label), - {R1,Rs3,Vn3} = body_instance(R0, Gs1, Rs2, Vn2, Label), - {[{Disj,R1}|L1],Rs3,Vn3}; -body_instance([{{if_then}=IT,C0,T0,_}|Gs0], Tail, Rs0, Vn0, Label) -> - {Gs1,Rs1,Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), - {T1,Rs2,Vn2} = body_instance(T0, Gs1, Rs1, Vn1, Label), - {C1,Rs3,Vn3} = body_instance(C0, [{{cut},Label,true}|T1], Rs2, Vn2, Label), - %% Append Gs1 directly to T1 to C1. - {[{IT,Label}|C1],Rs3,Vn3}; -body_instance([{{if_then_else}=ITE,C0,T0,E0,_}|Gs0], Tail, Rs0, Vn0, Label) -> - {Gs1,Rs1,Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), - {T1,Rs2,Vn2} = body_instance(T0, Gs1, Rs1, Vn1, Label), - {C1,Rs3,Vn3} = body_instance(C0, [{{cut},Label,true}|T1], Rs2, Vn2, Label), - {E1,Rs4,Vn4} = body_instance(E0, Gs1, Rs3, Vn3, Label), - {[{ITE,E1,Label}|C1],Rs4,Vn4}; -body_instance([{{once}=Once,G0,_}|Gs0], Tail, Rs0, Vn0, Label) -> - {Gs1,Rs1,Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), - {G1,Rs2,Vn2} = body_instance(G0, [{{cut},Label,true}|Gs1], Rs1, Vn1, Label), - {[{Once,Label}|G1],Rs2,Vn2}; -body_instance([G0|Gs0], Tail, Rs0, Vn0, Label) -> - {Gs1,Rs1,Vn1} = body_instance(Gs0, Tail, Rs0, Vn0, Label), - {G1,Rs2,Vn2} = term_instance(G0, Rs1, Vn1), - {[G1|Gs1],Rs2,Vn2}; -body_instance([], Tail, Rs, Vn, _Label) -> {Tail,Rs,Vn}. - -%% body_term(Body, Repls, VarNum) -> {Term,NewRepls,NewVarNum}. -%% Generate a copy of a body as a term with new, fresh unused -%% variables. No bindings from original variables to new -%% variables. It can handle replacing integer variables with -%% overlapping integer ranges. Don't check Term as it should already -%% be checked. Use orddict as there will seldom be many variables and -%% it it fast to setup. - -body_term([{{cut},_,_}|Gs0], Rs0, Vn0) -> - {Gs1,Rs1,Vn1} = body_term(Gs0, Rs0, Vn0), - {body_conj('!', Gs1),Rs1,Vn1}; -body_term([{{disj},L0,R0}|Gs0], Rs0, Vn0) -> - {Gs1,Rs1,Vn1} = body_term(Gs0, Rs0, Vn0), - {L1,Rs2,Vn2} = body_term(L0, Rs1, Vn1), - {R1,Rs3,Vn3} = body_term(R0, Rs2, Vn2), - {body_conj({';',L1,R1}, Gs1),Rs3,Vn3}; -body_term([{{if_then},C0,T0,_}|Gs0], Rs0, Vn0) -> - {Gs1,Rs1,Vn1} = body_term(Gs0, Rs0, Vn0), - {C1,Rs2,Vn2} = body_term(C0, Rs1, Vn1), - {T1,Rs3,Vn3} = body_term(T0, Rs2, Vn2), - {body_conj({'->',C1,T1}, Gs1),Rs3,Vn3}; -body_term([{{if_then_else},C0,T0,E0,_}|Gs0], Rs0, Vn0) -> - {Gs1,Rs1,Vn1} = body_term(Gs0, Rs0, Vn0), - {C1,Rs2,Vn2} = body_term(C0, Rs1, Vn1), - {T1,Rs3,Vn3} = body_term(T0, Rs2, Vn2), - {E1,Rs4,Vn4} = body_term(E0, Rs3, Vn3), - {body_conj({';',{'->',C1,T1},E1}, Gs1),Rs4,Vn4}; -body_term([{{once},G0,_}|Gs0], Rs0, Vn0) -> - {Gs1,Rs1,Vn1} = body_term(Gs0, Rs0, Vn0), - {G1,Rs2,Vn2} = body_term(G0, Rs1, Vn1), - {body_conj({once,G1}, Gs1),Rs2,Vn2}; -body_term([G0|Gs0], Rs0, Vn0) -> - {Gs1,Rs1,Vn1} = body_term(Gs0, Rs0, Vn0), - {G1,Rs2,Vn2} = term_instance(G0, Rs1, Vn1), - {body_conj(G1, Gs1),Rs2,Vn2}; -body_term([], Rs, Vn) -> {true,Rs,Vn}. - -body_conj(L, true) -> L; -body_conj(L, R) -> {',',L,R}. - -pred_ind({N,A}) -> {'/',N,A}. - -%% pred_ind(N, A) -> {'/',N,A}. - -%% Bindings -%% Bindings are kept in a dict where the key is the variable name. -%%-define(BIND, orddict). --define(BIND, dict). - -new_bindings() -> ?BIND:new(). - -add_binding({V}, Val, Bs0) -> - ?BIND:store(V, Val, Bs0). - -get_binding({V}, Bs) -> - ?BIND:find(V, Bs). - -%% deref(Term, Bindings) -> Term. -%% Dereference a variable, else just return the term. - -deref({V}=T0, Bs) -> - case ?BIND:find(V, Bs) of - {ok,T1} -> deref(T1, Bs); - error -> T0 - end; -deref(T, _) -> T. %Not a variable, return it. - -%% deref_list(List, Bindings) -> List. -%% Dereference the top-level checking that it is a list. - -deref_list([], _) -> []; %It already is a list -deref_list([_|_]=L, _) -> L; -deref_list({V}, Bs) -> - case ?BIND:find(V, Bs) of - {ok,L} -> deref_list(L, Bs); - error -> instantiation_error() - end; -deref_list(Other, _) -> type_error(list, Other). - -%% dderef(Term, Bindings) -> Term. -%% Do a deep dereference. Completely dereference all the variables -%% occuring in a term, even those occuring in a variables value. - -dderef(A, _) when ?IS_CONSTANT(A) -> A; -dderef([], _) -> []; -dderef([H0|T0], Bs) -> - [dderef(H0, Bs)|dderef(T0, Bs)]; -dderef({V}=Var, Bs) -> - case ?BIND:find(V, Bs) of - {ok,T} -> dderef(T, Bs); - error -> Var - end; -dderef(T, Bs) when is_tuple(T) -> - Es0 = tuple_to_list(T), - Es1 = dderef(Es0, Bs), - list_to_tuple(Es1). - -%% dderef_list(List, Bindings) -> List. -%% Dereference all variables to any depth but check that the -%% top-level is a list. - -dderef_list([], _Bs) -> []; -dderef_list([H|T], Bs) -> - [dderef(H, Bs)|dderef_list(T, Bs)]; -dderef_list({V}, Bs) -> - case ?BIND:find(V, Bs) of - {ok,L} -> dderef_list(L, Bs); - error -> instantiation_error() - end; -dderef_list(Other, _Bs) -> type_error(list, Other). - -%% initial_goal(Goal) -> {Goal,Bindings,NewVarNum}. -%% initial_goal(Goal, Bindings, VarNum) -> {Goal,NewBindings,NewVarNum}. -%% Check term for well-formedness as an Erlog term and replace '_' -%% variables with unique numbered variables. Error on non-well-formed -%% goals. - -initial_goal(Goal) -> initial_goal(Goal, new_bindings(), 0). - -initial_goal({'_'}, Bs, Vn) -> {{Vn},Bs,Vn+1}; %Anonymous variable -initial_goal({Name}=Var0, Bs, Vn) when is_atom(Name) -> - case get_binding(Var0, Bs) of - {ok,Var1} -> {Var1,Bs,Vn}; - error -> - Var1 = {Vn}, - {Var1,add_binding(Var0, Var1, Bs),Vn+1} - end; -initial_goal([H0|T0], Bs0, Vn0) -> - {H1,Bs1,Vn1} = initial_goal(H0, Bs0, Vn0), - {T1,Bs2,Vn2} = initial_goal(T0, Bs1, Vn1), - {[H1|T1],Bs2,Vn2}; -initial_goal([], Bs, Vn) -> {[],Bs,Vn}; -initial_goal(S, Bs0, Vn0) when ?IS_FUNCTOR(S) -> - As0 = tl(tuple_to_list(S)), - {As1,Bs1,Vn1} = initial_goal(As0, Bs0, Vn0), - {list_to_tuple([element(1, S)|As1]),Bs1,Vn1}; -initial_goal(T, Bs, Vn) when ?IS_ATOMIC(T) -> {T,Bs,Vn}; -initial_goal(T, _Bs, _Vn) -> type_error(callable, T). diff --git a/src/erlog_int.hrl b/src/erlog_int.hrl deleted file mode 100644 index f65ff70..0000000 --- a/src/erlog_int.hrl +++ /dev/null @@ -1,26 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_int.erl -%% Author : Robert Virding -%% Purpose : Basic interpreter of a Prolog definitions. - -%% Some standard type macros. - --define(IS_ATOMIC(T), (not (is_tuple(T) orelse (is_list(T) andalso T /= [])))). --define(IS_FUNCTOR(T), (is_tuple(T) andalso (tuple_size(T) >= 2) andalso is_atom(element(1, T)))). - -%% Define the choice point record --record(cp, {type,label,data,next,bs,vn}). --record(cut, {label,next}). diff --git a/src/erlog_io.erl b/src/erlog_io.erl deleted file mode 100644 index c5350fd..0000000 --- a/src/erlog_io.erl +++ /dev/null @@ -1,248 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_io.erl -%% Author : Robert Virding -%% Purpose : Some basic i/o functions for Erlog. -%% -%% Structures - {Functor,arg1, Arg2,...} where Functor is an atom -%% Variables - {Name} where Name is an atom or integer -%% Lists - Erlang lists -%% Atomic - Erlang constants -%% -%% There is no problem with the representation of variables as Prolog -%% functors of arity 0 are atoms. This representation is much easier -%% to test for, and create new variables with than using funny atom -%% names like '$1' (yuch!), and we need LOTS of variables. - --module(erlog_io). - --export([scan_file/1,read_file/1,read/1,read/2, - write/1,write/2,write1/1,writeq/1,writeq/2,writeq1/1, - write_canonical/1,write_canonical/2,write_canonical1/1]). - -scan_file(File) -> - case file:open(File, [read]) of - {ok,Fd} -> - try - {ok,scan_stream(Fd, 1)} - catch - throw:Term -> Term; - error:Error -> {error,einval,Error}; - exit:Exit -> {exit,einval,Exit} - after - file:close(Fd) - end; - Error -> Error - end. - -scan_stream(Fd, L0) -> - case scan_erlog_term(Fd, '', L0) of - {ok,Toks,L1} -> [Toks|scan_stream(Fd, L1)]; - {error,Error,_} -> throw({error,Error}); - {eof,_}=Eof -> Eof - end. - -%% read_file(FileName) -> {ok,[Term]} | {error,Error}. -%% Read a file containing Prolog terms. This has been taken from 'io' -%% but cleaned up using try. - -read_file(File) -> - case file:open(File, [read]) of - {ok,Fd} -> - try - {ok,read_stream(Fd, 1)} - catch - throw:Term -> Term; - error:Error -> {error,einval,Error}; - exit:Exit -> {exit,einval,Exit} - after - file:close(Fd) - end; - Error -> Error - end. - -read_stream(Fd, L0) -> - case scan_erlog_term(Fd, '', L0) of - {ok,Toks,L1} -> - case erlog_parse:term(Toks, L0) of - {ok,end_of_file} -> []; %Prolog does this. - {ok,Term} -> - [Term|read_stream(Fd, L1)]; - {error,What} -> throw({error,What}) - end; - {error,Error,_} -> throw({error,Error}); - {eof,_} -> [] - end. - -%% read([IoDevice], Prompt) -> Term. -%% A very simple read function. Returns the direct representation of -%% the term without variable processing. - -read(P) -> read(standard_io, P). - -read(Io, P) -> - case scan_erlog_term(Io, P, 1) of - {ok,Ts,_} -> - case erlog_parse:term(Ts) of - {ok,T} -> {ok,T}; - {error,Pe} -> {error,Pe} - end; - {error,Se,_} -> {error,Se}; - {eof,_} -> {ok,end_of_file} %Prolog does this - end. - -scan_erlog_term(Io, Prompt, Line) -> - io:request(Io, {get_until,Prompt,erlog_scan,tokens,[Line]}). - --record(ops, {op=false,q=true}). - -%% write([IoDevice], Term) -> ok. -%% writeq([IoDevice], Term) -> ok. -%% write_canonical([IoDevice], Term) -> ok. -%% A very simple write function. Does not pretty-print but can handle -%% operators. The xxx1 verions return an iolist of the characters. - -write(T) -> write(standard_io, T). - -write(Io, T) -> io:put_chars(Io, write1(T)). - -write1(T) -> write1(T, 1200, #ops{op=true,q=false}). - -writeq(T) -> writeq(standard_io, T). - -writeq(Io, T) -> io:put_chars(Io, writeq1(T)). - -writeq1(T) -> write1(T, 1200, #ops{op=true,q=true}). - -write_canonical(T) -> write_canonical(standard_io, T). - -write_canonical(Io, T) -> io:put_chars(Io, write_canonical1(T)). - -write_canonical1(T) -> write1(T, 1200, #ops{op=false,q=true}). - -%% write1(Term, Precedence, Ops) -> iolist(). -%% The function which does the actual writing. - -write1(T, Prec, Ops) when is_atom(T) -> write1_atom(T, Prec, Ops); -write1(T, _, _) when is_number(T) -> io_lib:write(T); -write1({V}, _, _) when is_integer(V) -> "_" ++ integer_to_list(V); -write1({V}, _, _) -> atom_to_list(V); %Variable -write1([H|T], _, Ops) -> - [$[,write1(H, 999, Ops),write1_tail(T, Ops),$]]; -write1([], _, _) -> "[]"; -write1({F,A}, Prec, #ops{op=true}=Ops) -> - case erlog_parse:prefix_op(F) of - {yes,OpP,ArgP} -> - Out = [write1(F, 1200, Ops),$\s,write1(A, ArgP, Ops)], - write1_prec(Out, OpP, Prec); - no -> - case erlog_parse:postfix_op(F) of - {yes,ArgP,OpP} -> - Out = [write1(A, ArgP, Ops),$\s,write1(F, 1200, Ops)], - write1_prec(Out, OpP, Prec); - no -> - [write1(F, 1200, Ops),$(,write1(A, 999, Ops),$)] - end - end; -write1({',',A1,A2}, Prec, #ops{op=true}=Ops) -> - %% Must special case , here. - Out = [write1(A1, 999, Ops),", ",write1(A2, 1000, Ops)], - write1_prec(Out, 1000, Prec); -write1({F,A1,A2}, Prec, #ops{op=true}=Ops) -> - case erlog_parse:infix_op(F) of - {yes,Lp,OpP,Rp} -> - Out = [write1(A1, Lp, Ops),$\s,write1(F, 1200, Ops), - $\s,write1(A2, Rp,Ops)], - write1_prec(Out, OpP, Prec); - no -> - [write1(F, 1200, Ops),$(,write1(A1, 999, Ops), - $,,write1(A2, 999, Ops),$)] - end; -write1(T, _, Ops) when is_tuple(T) -> - [F,A1|As] = tuple_to_list(T), - [write1(F, 1200, Ops),$(,write1(A1, 999, Ops),write1_tail(As, Ops),$)]; -write1(T, _, _) -> %Else use default Erlang. - io_lib:write(T). - -%% write1_prec(OutString, OpPrecedence, Precedence) -> iolist(). -%% Encase OutString with (..) if op precedence higher than -%% precedence. - -write1_prec(Out, OpP, Prec) when OpP > Prec -> [$(,Out,$)]; -write1_prec(Out, _, _) -> Out. - -write1_tail([T|Ts], Ops) -> - [$,,write1(T, 999, Ops)|write1_tail(Ts, Ops)]; -write1_tail([], _) -> []; -write1_tail(T, Ops) -> [$|,write1(T, 999, Ops)]. - -write1_atom(A, Prec, #ops{q=false}) -> %No quoting - write1_atom_1(A, atom_to_list(A), Prec); -write1_atom(A, Prec, _) when A == '!'; A == ';' -> %Special atoms - write1_atom_1(A, atom_to_list(A), Prec); -write1_atom(A, Prec, _) -> - case atom_to_list(A) of - [C|Cs]=Acs -> - case (lower_case(C) andalso alpha_chars(Cs)) - orelse symbol_chars(Acs) of - true -> write1_atom_1(A, Acs, Prec); - false -> - Qcs = quote_atom(Acs), - write1_atom_1(A, Qcs, Prec) - end; - [] -> write1_atom_1(A, "''", Prec) - end. - -write1_atom_1(A, Acs, Prec) -> - case erlog_parse:prefix_op(A) of - {yes,OpP,_} when OpP > Prec -> [$(,Acs,$)]; - _ -> - case erlog_parse:postfix_op(A) of - {yes,_,OpP} when OpP > Prec -> [$(,Acs,$)]; - _ -> Acs - end - end. - -quote_atom(Acs) -> [$',Acs,$']. %Very naive as yet. - -symbol_chars(Cs) -> lists:all(fun symbol_char/1, Cs). - -symbol_char($-) -> true; -symbol_char($#) -> true; -symbol_char($$) -> true; -symbol_char($&) -> true; -symbol_char($*) -> true; -symbol_char($+) -> true; -symbol_char($.) -> true; -symbol_char($/) -> true; -symbol_char($\\) -> true; -symbol_char($:) -> true; -symbol_char($<) -> true; -symbol_char($=) -> true; -symbol_char($>) -> true; -symbol_char($?) -> true; -symbol_char($@) -> true; -symbol_char($^) -> true; -symbol_char($~) -> true; -symbol_char(_) -> false. - -lower_case(C) -> (C >= $a) and (C =< $z). - -alpha_chars(Cs) -> lists:all(fun alpha_char/1, Cs). - -alpha_char($_) -> true; -alpha_char(C) when C >= $A, C =< $Z -> true; -alpha_char(C) when C >= $0, C =< $9 -> true; -alpha_char(C) -> lower_case(C). diff --git a/src/erlog_lists.erl b/src/erlog_lists.erl deleted file mode 100644 index 564de43..0000000 --- a/src/erlog_lists.erl +++ /dev/null @@ -1,204 +0,0 @@ -%% Copyright (c) 2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_lists.erl -%% Author : Robert Virding -%% Purpose : Standard Erlog lists library. -%% -%% This is a standard lists library for Erlog. Everything here is -%% pretty basic and common to most Prologs. We are experimenting here -%% and some predicates are compiled. We only get a small benefit when -%% only implementing indexing on the first argument. - --module(erlog_lists). - --include("erlog_int.hrl"). - -%% Main interface functions. --export([load/1]). - -%% Library functions. --export([append_3/6,insert_3/6,member_2/6,memberchk_2/6,reverse_2/6,sort_2/6]). - -%%-compile(export_all). - --import(lists, [map/2,foldl/3]). - -%% We use these a lot so we import them for cleaner code. --import(erlog_int, [prove_body/5,unify_prove_body/7,unify_prove_body/9,fail/2, - add_binding/3,make_vars/2, - deref/2,dderef/2,dderef_list/2,unify/3, - term_instance/2, - add_built_in/2,add_compiled_proc/4, - asserta_clause/2,assertz_clause/2]). - -%% load(Database) -> Database. -%% Assert predicates into the database. - -load(Db0) -> - %% Compiled common list library. - Db1 = foldl(fun ({Head,M,F}, Db) -> - add_compiled_proc(Head, M, F, Db) end, Db0, - [ - {{append,3},?MODULE,append_3}, - {{insert,3},?MODULE,insert_3}, - {{member,2},?MODULE,member_2}, - {{memberchk,2},?MODULE,memberchk_2}, - {{reverse,2},?MODULE,reverse_2}, - {{sort,2},?MODULE,sort_2} - ]), - %% Finally interpreted common list library. - foldl(fun (Clause, Db) -> assertz_clause(Clause, Db) end, Db1, - [ - %% insert(L, X, [X|L]). insert([H|L], X, [H|L1]) :- insert(L, X, L1). - %% delete([X|L], X, L). delete([H|L], X, [H|L1]) :- delete(L, X, L1). - {':-',{delete,{1},{2},{3}},{insert,{3},{2},{1}}}, - %% perm([], []). - %% perm([X|Xs], Ys1) :- perm(Xs, Ys), insert(Ys, X, Ys1). - {perm,[],[]}, - {':-',{perm,[{1}|{2}],{3}},{',',{perm,{2},{4}},{insert,{4},{1},{3}}}} - ]). - -%% append_3(Head, NextGoal, Choicepoints, Bindings, VarNum, Database) -> void. -%% append([], L, L). -%% append([H|T], L, [H|L1]) :- append(T, L, L1). -%% Here we attempt to compile indexing in the first argument. - -append_3({append,A1,L,A3}, Next0, Cps, Bs0, Vn, Db) -> - case deref(A1, Bs0) of - [] -> %Cannot backtrack - unify_prove_body(L, A3, Next0, Cps, Bs0, Vn, Db); - [H|T] -> %Cannot backtrack - L1 = {Vn}, - Next1 = [{append,T,L,L1}|Next0], - unify_prove_body(A3, [H|L1], Next1, Cps, Bs0, Vn+1, Db); - {_}=Var -> %This can backtrack - FailFun = fun (LCp, LCps, LDb) -> - fail_append_3(LCp, LCps, LDb, Var, L, A3) - end, - Cp = #cp{type=compiled,data=FailFun,next=Next0,bs=Bs0,vn=Vn}, - Bs1 = add_binding(Var, [], Bs0), - unify_prove_body(L, A3, Next0, [Cp|Cps], Bs1, Vn, Db); - _ -> fail(Cps, Db) %Will fail here! - end. - -fail_append_3(#cp{next=Next0,bs=Bs0,vn=Vn}, Cps, Db, A1, L, A3) -> - H = {Vn}, - T = {Vn+1}, - L1 = {Vn+2}, - Bs1 = add_binding(A1, [H|T], Bs0), %A1 always a variable here. - Next1 = [{append,T,L,L1}|Next0], - unify_prove_body(A3, [H|L1], Next1, Cps, Bs1, Vn+3, Db). - -%% insert_3(Head, NextGoal, Choicepoints, Bindings, VarNum, Database) -> void. -%% insert(L, X, [X|L]). -%% insert([H|L], X, [H|L1]) :- insert(L, X, L1). - -insert_3({insert,A1,A2,A3}, Next, Cps, Bs, Vn, Db) -> - FailFun = fun (LCp, LCps, LDb) -> - fail_insert_3(LCp, LCps, LDb, A1, A2, A3) - end, - Cp = #cp{type=compiled,data=FailFun,next=Next,bs=Bs,vn=Vn}, - unify_prove_body(A3, [A2|A1], Next, [Cp|Cps], Bs, Vn, Db). - -fail_insert_3(#cp{next=Next0,bs=Bs,vn=Vn}, Cps, Db, A1, X, A3) -> - H = {Vn}, - L = {Vn+1}, - L1 = {Vn+2}, - Next1 = [{insert,L,X,L1}|Next0], - unify_prove_body(A1, [H|L], A3, [H|L1], Next1, Cps, Bs, Vn+3, Db). - -%% member_2(Head, NextGoal, Choicepoints, Bindings, VarNum, Database) -> void. -%% member(X, [X|_]). -%% member(X, [_|T]) :- member(X, T). - -member_2({member,A1,A2}, Next, Cps, Bs, Vn, Db) -> - FailFun = fun (LCp, LCps, LDb) -> - fail_member_2(LCp, LCps, LDb, A1, A2) - end, - Cp = #cp{type=compiled,data=FailFun,next=Next,bs=Bs,vn=Vn}, - T = {Vn}, - unify_prove_body(A2, [A1|T], Next, [Cp|Cps], Bs, Vn+1, Db). - -fail_member_2(#cp{next=Next0,bs=Bs,vn=Vn}, Cps, Db, A1, A2) -> - H = {Vn}, - T = {Vn+1}, - Next1 = [{member,A1,T}|Next0], - unify_prove_body(A2, [H|T], Next1, Cps, Bs, Vn+2, Db). - -%% memberchk_2(Head, NextGoal, Choicepoints, Bindings, VarNum, Database) -> void. -%% memberchk(X, [X|_]) :- !. -%% memberchk(X, [_|T]) :- member(X, T). -%% We don't build the list and we never backtrack so we can be smart -%% and match directly. Should we give a type error? - -memberchk_2({memberchk,A1,A2}, Next, Cps, Bs0, Vn, Db) -> - case deref(A2, Bs0) of - [H|T] -> - case unify(A1, H, Bs0) of - {succeed,Bs1} -> - prove_body(Next, Cps, Bs1, Vn, Db); - fail -> - memberchk_2({memberchk,A1,T}, Next, Cps, Bs0, Vn, Db) - end; - {_} -> erlog_int:instantiation_error(); - _ -> fail(Cps, Db) - end. - -%% reverse_2(Head, NextGoal, Choicepoints, Bindings, VarNum, Database) -> void. -%% reverse([], []). -%% reverse([H|L1], L) :- reverse(L1, L2), append(L2, [H], L). -%% Here we attempt to compile indexing in the first argument. - -reverse_2({reverse,A1,A2}, Next0, Cps, Bs0, Vn, Db) -> - case deref(A1, Bs0) of - [] -> - unify_prove_body(A2, [], Next0, Cps, Bs0, Vn, Db); - [H|T] -> - L = {Vn}, - L1 = A2, - %% Naive straight expansion of body. - %%Next1 = [{reverse,T,L},{append,L,[H],L1}|Next0], - %%prove_body(Next1, Cps, Bs0, Vn+1, Db); - %% Smarter direct calling of local function. - Next1 = [{append,L,[H],L1}|Next0], - reverse_2({reverse,T,L}, Next1, Cps, Bs0, Vn+1, Db); - {_}=Var -> - FailFun = fun (LCp, LCps, LDb) -> - fail_reverse_2(LCp, LCps, LDb, Var, A2) - end, - Cp = #cp{type=compiled,data=FailFun,next=Next0,bs=Bs0,vn=Vn}, - Bs1 = add_binding(Var, [], Bs0), - unify_prove_body(A2, [], Next0, [Cp|Cps], Bs1, Vn, Db); - _ -> fail(Cps, Db) %Will fail here! - end. - -fail_reverse_2(#cp{next=Next,bs=Bs0,vn=Vn}, Cps, Db, A1, A2) -> - H = {Vn}, - T = {Vn+1}, - L1 = A2, - L = {Vn+2}, - Bs1 = add_binding(A1, [H|T], Bs0), - %%Next1 = [{reverse,T,L},{apperse,L,[H],L1}|Next], - %%prove_body(Next1, Cps, Bs1, Vn+3, Db). - Next1 = [{append,L,[H],L1}|Next], - reverse_2({reverse,T,L}, Next1, Cps, Bs1, Vn+3, Db). - -%% sort_2(Head, NextGoal, Choicepoints, Bindings, VarNum, Database) -> void. -%% sort(List, SortedList). - -sort_2({sort,L0,S}, Next, Cps, Bs, Vn, Db) -> - %% This may throw an erlog error, we don't catch it here. - L1 = lists:usort(dderef_list(L0, Bs)), - unify_prove_body(S, L1, Next, Cps, Bs, Vn, Db). diff --git a/src/erlog_parse.erl b/src/erlog_parse.erl deleted file mode 100644 index fc88d84..0000000 --- a/src/erlog_parse.erl +++ /dev/null @@ -1,313 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_parse.erl -%% Author : Robert Virding -%% Purpose : Erlog parser -%% -%% Parses Erlog tokens into Erlog terms. Based on the Standard prolog -%% parser and directly coded from the parser description. To handle -%% back-tracking in the parser we use a continuation style using funs -%% where each fun handles one step of what follows. This allows -%% back-tracking. This may not be a specially efficient way of -%% parsing but it is simple and easy to derive from the -%%% description. No logical variables are necessary here. - --module(erlog_parse). - --export([term/1,term/2,format_error/1]). --export([prefix_op/1,infix_op/1,postfix_op/1]). - --compile({nowarn_unused_function,[type/1,line/1,val/1]}). -%% -compile(export_all). - -term(Toks) -> term(Toks, 1). - -term(Toks, _) -> - case term(Toks, 1200, fun(Ts, T) -> all_read(Ts, T) end) of - {succeed,Term} -> {ok,Term}; - {fail,{Line,Error}} -> {error,{Line,?MODULE,Error}} - end. - -all_read([{'.',_}], Term) -> {succeed,Term}; -all_read([{T,L}|_], _) -> syntax_error(L, {operator_expected,T}); -all_read([{_,L,V}|_], _) -> syntax_error(L, {operator_expected,V}); -all_read([], _) -> syntax_error(9999, premature_end). - -syntax_error(Line, Error) -> {fail,{Line,Error}}. -%% syntax_error(Line, Error) -> -%% io:fwrite("se: ~p\n", [{Line,Error}]), {fail,{Line,Error}}. - -format_error(premature_end) -> "premature end"; -format_error({operator_expected,T}) -> - io_lib:fwrite("operator expected before: ~w", [T]); -format_error({illegal,T}) -> - io_lib:fwrite("illegal token: ~w", [T]); -format_error(no_term) -> "missing term"; -format_error({op_priority,Op}) -> - io_lib:fwrite("operator priority clash: ~w", [Op]); -format_error({expected,T}) -> - io_lib:fwrite("~w or operator expected", [T]). - -%% term(Tokens, Precedence, Next) -> {succeed,Term} | {fail,Error}. - -term([{number,_,N}|Toks], Prec, Next) -> rest_term(Toks, N, 0, Prec, Next); -term([{string,_,S}|Toks], Prec, Next) -> rest_term(Toks, S, 0, Prec, Next); -term([{'(',_}|Toks], Prec, Next) -> - bracket_term(Toks, Prec, Next); -term([{' (',_}|Toks], Prec, Next) -> - bracket_term(Toks, Prec, Next); -term([{'{',L},{'}',_}|Toks], Prec, Next) -> - term([{atom,L,'{}'}|Toks], Prec, Next); -term([{'{',_}|Toks0], Prec, Next) -> - term(Toks0, 1200, - fun (Toks1, Term) -> - expect(Toks1, '}', Term, - fun (Toks2, Term1) -> - rest_term(Toks2, {'{}',Term1}, 0, Prec, Next) - end) - end); -term([{'[',_},{']',_}|Toks], Prec, Next) -> - rest_term(Toks, [], 0, Prec, Next); -term([{'[',_}|Toks0], Prec, Next) -> - term(Toks0, 999, - fun (Toks1, E) -> - list_elems(Toks1, [E], - fun (Toks2, List) -> - rest_term(Toks2, List, 0, Prec, Next) - end) - end); -term([{var,_,V}|Toks], Prec, Next) -> rest_term(Toks, {V}, 0, Prec, Next); -term([{atom,_,F},{'(',_}|Toks0], Prec, Next) -> - %% Compound term in functional syntax. - term(Toks0, 999, - fun (Toks1, A) -> - arg_list(Toks1, [A], - fun (Toks2, Args) -> - %% Equivalence of '.'/2 and lists. - Term = case {F,Args} of - {'.',[H,T]} -> [H|T]; - _ -> list_to_tuple([F|Args]) - end, - rest_term(Toks2, Term, 0, Prec, Next) - end) - end); -term([{atom,L,Op}|Toks0], Prec, Next) -> - case prefix_op(Op) of - {yes,OpP,ArgP} when Prec >= OpP -> - case possible_right_operand(Toks0) of - true -> - %% First try as prefix op, then as atom. - Next1 = fun (Toks1, Arg) -> - rest_term(Toks1, {Op,Arg}, OpP, Prec, Next) - end, - cp([fun () -> term(Toks0, ArgP, Next1) end, - fun () -> rest_term(Toks0, Op, 0, Prec, Next) end]); - false -> rest_term(Toks0, Op, 0, Prec, Next) - end; - {yes,_,_} -> - syntax_error(L, {op_priority,Op}); - no -> rest_term(Toks0, Op, 0, Prec, Next) - end; -term([{T,L}|_], _, _) -> syntax_error(L, {illegal,T}); -term([{_,L,V}|_], _, _) -> syntax_error(L, {illegal,V}); -term([], _, _) -> syntax_error(9999, no_term). - -%% possible_right_operand(Tokens) -> true | false. -%% Test if there maybe a possible right operand. - -possible_right_operand([{')',_}|_]) -> false; -possible_right_operand([{'}',_}|_]) -> false; -possible_right_operand([{']',_}|_]) -> false; -possible_right_operand([{',',_}|_]) -> false; -possible_right_operand([{'|',_}|_]) -> false; -possible_right_operand(_) -> true. - -%% bracket_term(Tokens, Precedence, Next) -> -%% {succeed,Term} | {fail,Error}. - -bracket_term(Toks0, Prec, Next) -> - term(Toks0, 1200, - fun (Toks1, Term) -> - expect(Toks1, ')', Term, - fun (Toks2, Term1) -> - rest_term(Toks2, Term1, 0, Prec, Next) - end) - end). - -%% rest_term(Tokens, Term, LeftPrec, Precedence, Next) -> -%% {succeed,Term} | {fail,Error}. -%% Have a term to the left, test if operator follows or just go on. - -rest_term([{atom,L,Op}|Toks0], Term, Left, Prec, Next) -> - cp([fun () -> infix_term(Op, L, Toks0, Term, Left, Prec, Next) end, - fun () -> postfix_term(Op, L, Toks0, Term, Left, Prec, Next) end, - fun () -> Next([{atom,L,Op}|Toks0], Term) end]); -rest_term([{',',L}|Toks0], Term, Left, Prec, Next) -> - %% , is an operator as well as a separator. - if Prec >= 1000, Left < 1000 -> - term(Toks0, 1000, - fun (Toks1, RArg) -> - rest_term(Toks1, {',',Term,RArg}, 1000, Prec, Next) - end); - true -> Next([{',',L}|Toks0], Term) - end; -rest_term(Toks, Term, _, _, Next) -> - Next(Toks, Term). - -%% infix_term(Operator, Line, Tokens, Term, LeftPrec, Prec, Next) -> -%% {succeed,Term} | {fail,Error}. -%% Test if infix operator of correct priority, fail with -%% operator_expected if not an operator to have some error. - -infix_term(Op, L, Toks0, Term, Left, Prec, Next) -> - case infix_op(Op) of - {yes,LAP,OpP,RAP} when Prec >= OpP, Left =< LAP -> - term(Toks0, RAP, - fun (Toks1, Arg2) -> - rest_term(Toks1, {Op,Term,Arg2}, OpP, Prec, Next) - end); - {yes,_,_,_} -> syntax_error(L, {op_priority,Op}); - no -> fail - end. - -%% postfix_term(Operator, Line, Tokens, Term, LeftPrec, Prec, Next) -> -%% {succeed,Term} | {fail,Error}. -%% Test if postfix operator of correct priority, fail with -%% operator_expected if not an operator to have some error. - -postfix_term(Op, L, Toks0, Term, Left, Prec, Next) -> - case postfix_op(Op) of - {yes,ArgP,OpP} when Prec >= OpP, Left =< ArgP -> - rest_term(Toks0, {Op,Term}, OpP, Prec, Next); - {yes,_,_} -> syntax_error(L, {op_priority,Op}); - no -> fail - end. - -%% list_elems(Tokens, RevElems, Next) -> -%% {succeed,Term} | {fail,Error}. - -list_elems([{',',_}|Toks0], REs, Next) -> - term(Toks0, 999, - fun (Toks1, E) -> - list_elems(Toks1, [E|REs], Next) - end); -list_elems([{'|',_}|Toks0], REs, Next) -> - term(Toks0, 999, - fun (Toks1, E) -> - expect(Toks1, ']', lists:reverse(REs, E), Next) - end); -list_elems(Toks, REs, Next) -> - expect(Toks, ']', lists:reverse(REs), Next). - -%% arg_list(Tokens, RevArgs, Next) -> {succeed,Term} | {fail,Error}. - -arg_list([{',',_}|Toks0], RAs, Next) -> - term(Toks0, 999, - fun (Toks1, Arg) -> - arg_list(Toks1, [Arg|RAs], Next) - end); -arg_list(Toks, RAs, Next) -> - expect(Toks, ')', lists:reverse(RAs), Next). - -%% expect(Tokens, TokenType, Term, Next) -> {succeed,Term} | {fail,Error}. - -expect([T|Toks], Tok, Term, Next) -> - case type(T) of - Tok -> Next(Toks, Term); - _ -> syntax_error(line(T), {expected,Tok}) - end; -expect([], Tok, _, _) -> syntax_error(9999, {expected,Tok}). - -%% cp(Choices) -> {succeed,Term} | {fail,_} | fail. -%% Special choice point handler for parser. If all clauses fail then -%% fail with first fail value, this usually gives better error report. - -cp([C|Cs]) -> - case C() of - {succeed,Res} -> {succeed,Res}; - {fail,_}=Fail -> cp(Cs, Fail); %Try rest with first fail - fail -> cp(Cs) %Stay till we get reason - end. - -cp([C|Cs], Fail) -> - case C() of - {succeed,Res} -> {succeed,Res}; - {fail,_} -> cp(Cs, Fail); %Drop this fail, use first - fail -> cp(Cs, Fail) - end; -cp([], Fail) -> Fail. - -%% type(Tok) -> Line. -%% line(Tok) -> Line. -%% val(Tok) -> Value. - -type(Tok) -> element(1, Tok). -line(Tok) -> element(2, Tok). -val(Tok) -> element(3, Tok). - -%% prefix_op(Op) -> {yes,Prec,ArgPrec} | no. - -prefix_op('?-') -> {yes,1200,1199}; %fx 1200 -prefix_op(':-') -> {yes,1200,1199}; %fx 1200 -prefix_op('\\+') -> {yes,900,900}; %fy 900 -prefix_op('+') -> {yes,200,200}; %fy 200 -prefix_op('-') -> {yes,200,200}; %fy 200 -prefix_op('\\') -> {yes,200,200}; %fy 200 -prefix_op(_Op) -> no. %The rest - -%% postfix_op(Op) -> {yes,ArgPrec,Prec} | no. - -postfix_op('+') -> {yes,500,500}; -postfix_op('*') -> {yes,400,400}; -postfix_op(_Op) -> no. - -%% infix_op(Op) -> {yes,LeftArgPrec,Prec,RightArgPrec} | no. - -infix_op(':-') -> {yes,1199,1200,1199}; %xfx 1200 -infix_op('-->') -> {yes,1199,1200,1199}; %xfx 1200 -infix_op(';') -> {yes,1099,1100,1100}; %xfy 1100 -infix_op('->') -> {yes,1049,1050,1050}; %xfy 1050 -infix_op(',') -> {yes,999,1000,1000}; %xfy 1000 -infix_op('=') -> {yes,699,700,699}; %xfx 700 -infix_op('\\=') -> {yes,699,700,699}; %xfx 700 -infix_op('\\==') -> {yes,699,700,699}; %xfx 700 -infix_op('==') -> {yes,699,700,699}; %xfx 700 -infix_op('@<') -> {yes,699,700,699}; %xfx 700 -infix_op('@=<') -> {yes,699,700,699}; %xfx 700 -infix_op('@>') -> {yes,699,700,699}; %xfx 700 -infix_op('@>=') -> {yes,699,700,699}; %xfx 700 -infix_op('=..') -> {yes,699,700,699}; %xfx 700 -infix_op('is') -> {yes,699,700,699}; %xfx 700 -infix_op('=:=') -> {yes,699,700,699}; %xfx 700 -infix_op('=\\=') -> {yes,699,700,699}; %xfx 700 -infix_op('<') -> {yes,699,700,699}; %xfx 700 -infix_op('=<') -> {yes,699,700,699}; %xfx 700 -infix_op('>') -> {yes,699,700,699}; %xfx 700 -infix_op('>=') -> {yes,699,700,699}; %xfx 700 -infix_op(':') -> {yes,599,600,600}; %xfy 600 -infix_op('+') -> {yes,500,500,499}; %yfx 500 -infix_op('-') -> {yes,500,500,499}; %yfx 500 -infix_op('/\\') -> {yes,500,500,499}; %yfx 500 -infix_op('\\/') -> {yes,500,500,499}; %yfx 500 -infix_op('*') -> {yes,400,400,399}; %yfx 400 -infix_op('/') -> {yes,400,400,399}; %yfx 400 -infix_op('//') -> {yes,400,400,399}; %yfx 400 -infix_op('rem') -> {yes,400,400,399}; %yfx 400 -infix_op('mod') -> {yes,400,400,399}; %yfx 400 -infix_op('<<') -> {yes,400,400,399}; %yfx 400 -infix_op('>>') -> {yes,400,400,399}; %yfx 400 -infix_op('**') -> {yes,199,200,199}; %xfx 200 -infix_op('^') -> {yes,199,200,200}; %xfy 200 -infix_op(_Op) -> no. diff --git a/src/erlog_shell.erl b/src/erlog_shell.erl deleted file mode 100644 index 4199cf8..0000000 --- a/src/erlog_shell.erl +++ /dev/null @@ -1,108 +0,0 @@ -%% Copyright (c) 2008-2013 Robert Virding -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. - -%% File : erlog_shell.erl -%% Author : Robert Virding -%% Purpose : A simple Erlog shell. - --module(erlog_shell). - --export([start/0,start/1,server/0,server/1]). - --import(lists, [foldl/3,foreach/2]). - -start() -> start(default). - -start(P) -> - spawn(fun () -> server(P) end). - -server() -> server(default). - -server(_) -> - io:fwrite("Erlog Shell V~s (abort with ^G)\n", - [erlang:system_info(version)]), - server_loop(erlog:new()). - -%% A simple Erlog shell similar to a "normal" Prolog shell. It allows -%% user to enter goals, see resulting bindings and request next -%% solution. - -server_loop(P0) -> - case erlog_io:read('| ?- ') of - {ok,halt} -> ok; - {ok,Files} when is_list(Files) -> - {{ok,Db0},P1} = P0(get_db), - case reconsult_files(Files, Db0) of - {ok,Db1} -> - io:fwrite("Yes\n"), - {ok,P2} = P1({set_db,Db1}), - server_loop(P2); - {erlog_error,Error} -> - io:fwrite("Error: ~p\n", [Error]), - server_loop(P0); - {error,{L,Pm,Pe}} -> - io:fwrite("Error: ~w: ~s\n", [L,Pm:format_error(Pe)]), - server_loop(P0); - {error,Error} -> - io:fwrite("Error: ~p\n", [Error]), - server_loop(P0) - end; - {ok,Goal} -> - shell_prove_result(P0({prove,Goal})); - {error,{_,Em,E}} -> - io:fwrite("Error: ~s\n", [Em:format_error(E)]), - server_loop(P0) - end. - -reconsult_files([F|Fs], Db0) -> - case erlog_file:reconsult(F, Db0) of - {ok,Db1} -> reconsult_files(Fs, Db1); - {erlog_error,Error} -> {erlog_error,Error}; - {error,Error} -> {error,Error} - end; -reconsult_files([], Db) -> {ok,Db}; -reconsult_files(Other, _Db) -> {error,{type_error,list,Other}}. - -shell_prove_result({{succeed,Vs},P}) -> show_bindings(Vs, P); -shell_prove_result({fail,P}) -> - io:fwrite("No\n"), - server_loop(P); -shell_prove_result({{error,Error},P}) -> - %% Errors from the Erlog interpreters. - io:fwrite("Error: ~p\n", [Error]), - server_loop(P); -shell_prove_result({{'EXIT',Error},P}) -> %No new database here - %% Errors and exits from user code. - io:fwrite("EXIT: ~p\n", [Error]), - server_loop(P). - -%% show_bindings(VarList, Prolog()) -%% Show the bindings and query user for next solution. - -show_bindings([], P) -> - io:fwrite("Yes\n"), - server_loop(P); -show_bindings(Vs, P) -> - foreach(fun ({Name,Val}) -> - Out = erlog_io:writeq1({'=',{Name},Val}), - io:fwrite("~s\n", [Out]) - end, Vs), - Line = io:get_line(': '), - case string:chr(Line, $;) of - 0 -> - io:fwrite("Yes\n"), - server_loop(P); - _ -> - shell_prove_result(P(next_solution)) - end. diff --git a/src/interface/debugger/erlog_simple_debugger.erl b/src/interface/debugger/erlog_simple_debugger.erl new file mode 100644 index 0000000..4ecc7e0 --- /dev/null +++ b/src/interface/debugger/erlog_simple_debugger.erl @@ -0,0 +1,306 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 19. Сент. 2014 16:09 +%%%------------------------------------------------------------------- +-module(erlog_simple_debugger). +-author("tihon"). + +-behaviour(gen_server). + +%% API +-export([start_link/0, configure/1, process_reply/1]). + +%% gen_server callbacks +-export([init/1, + handle_call/3, + handle_cast/2, + handle_info/2, + terminate/2, + code_change/3]). + +-define(SERVER, ?MODULE). + +-record(state, +{ + policy = listing %default policy of debugger is listing. +}). +%% policy can be: +%% next N - make N commands and stop +%% stop Pred - stop when predicate Pred will be executing +%% listing - do not stop - just print every function result +%% spy Pred - do not stop, pring only predicate Pred result + +%%%=================================================================== +%%% API +%%%=================================================================== +-spec process_reply(dict:dict()) -> list(). +process_reply(Dict) -> + case dict:size(Dict) of + 0 -> []; + _ -> process_vars(Dict) + end. + +%%-------------------------------------------------------------------- +%% @doc +%% Starts the server +%% +%% @end +%%-------------------------------------------------------------------- +-spec(start_link() -> + {ok, Pid :: pid()} | ignore | {error, Reason :: term()}). +start_link() -> + gen_server:start_link({local, ?SERVER}, ?MODULE, [], []). + +%%%=================================================================== +%%% gen_server callbacks +%%%=================================================================== +-spec configure(pid()) -> ok. +configure(Debugger) -> gen_server:call(Debugger, conf, infinity). + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Initializes the server +%% +%% @spec init(Args) -> {ok, State} | +%% {ok, State, Timeout} | +%% ignore | +%% {stop, Reason} +%% @end +%%-------------------------------------------------------------------- +-spec(init(Args :: term()) -> + {ok, State :: #state{}} | {ok, State :: #state{}, timeout() | hibernate} | + {stop, Reason :: term()} | ignore). +init([]) -> + {ok, #state{}}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling call messages +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_call(Request :: term(), From :: {pid(), Tag :: term()}, + State :: #state{}) -> + {reply, Reply :: term(), NewState :: #state{}} | + {reply, Reply :: term(), NewState :: #state{}, timeout() | hibernate} | + {noreply, NewState :: #state{}} | + {noreply, NewState :: #state{}, timeout() | hibernate} | + {stop, Reason :: term(), Reply :: term(), NewState :: #state{}} | + {stop, Reason :: term(), NewState :: #state{}}). +handle_call(conf, _From, State) -> + Policy = process_action(), + {reply, ok, State#state{policy = Policy}}; +handle_call({stop, Functor, Vars}, _From, State) -> + io:fwrite("Erlog debugger stopped execution on command ~p with memory: ~p.~n", [Functor, process_reply(Vars)]), + Policy = process_action(), + {reply, ok, State#state{policy = Policy}}; +handle_call({_, Functor, Vars}, _From, State = #state{policy = {stop, Rule} = Old}) -> %stopping + Fun = + fun() -> + io:fwrite("Erlog debugger stopped execution on command ~p with memory: ~p.~n", [Functor, process_reply(Vars)]), + process_action() + end, + Polisy = case process_match(Functor, Fun, Rule) of + false -> + io:format("Skip ~p~n", [Functor]), + Old; %use old policy + NewPolicy -> NewPolicy %update policy + end, + {reply, ok, State#state{policy = Polisy}}; +handle_call({_, Functor, Vars}, _From, State = #state{policy = {next, N, M}}) when N =< 1 -> %counting steps ending + io:fwrite("Erlog debugger stopped execution on command ~p with memory: ~p.~n", [Functor, process_reply(Vars)]), + Policy = case select_next() of + skip -> {next, M, M}; %use old policy - update steps num + NewPolicy -> NewPolicy %update policy + end, + {reply, ok, State#state{policy = Policy}}; +handle_call({_, Functor, Vars}, _From, State = #state{policy = {spy, Rule}}) -> %spying for predicate + Fun = + fun() -> + io:format("Execute ~p, memory: ~p~n", [Functor, process_reply(Vars)]) + end, + process_match(Functor, Fun, Rule), + {reply, ok, State}; +handle_call({_, Functor, _}, _From, State = #state{policy = {next, N, M}}) -> %next = counting steps + io:format("Skip ~p~n", [Functor]), + {reply, ok, State#state{policy = {next, N - 1, M}}}; +handle_call({_Res, Functor, Vars}, _From, State = #state{policy = listing}) -> %listing + io:format("Execute ~p, memory: ~p~n", [Functor, process_reply(Vars)]), + {reply, ok, State}; +handle_call(_Request, _From, State) -> + {reply, ok, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling cast messages +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_cast(Request :: term(), State :: #state{}) -> + {noreply, NewState :: #state{}} | + {noreply, NewState :: #state{}, timeout() | hibernate} | + {stop, Reason :: term(), NewState :: #state{}}). +handle_cast(_Request, State = #state{}) -> + {noreply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling all non call/cast messages +%% +%% @spec handle_info(Info, State) -> {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} +%% @end +%%-------------------------------------------------------------------- +-spec(handle_info(Info :: timeout() | term(), State :: #state{}) -> + {noreply, NewState :: #state{}} | + {noreply, NewState :: #state{}, timeout() | hibernate} | + {stop, Reason :: term(), NewState :: #state{}}). +handle_info(_Info, State) -> + {noreply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% This function is called by a gen_server when it is about to +%% terminate. It should be the opposite of Module:init/1 and do any +%% necessary cleaning up. When it returns, the gen_server terminates +%% with Reason. The return value is ignored. +%% +%% @spec terminate(Reason, State) -> void() +%% @end +%%-------------------------------------------------------------------- +-spec(terminate(Reason :: (normal | shutdown | {shutdown, term()} | term()), + State :: #state{}) -> term()). +terminate(_Reason, _State) -> + ok. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Convert process state when code is changed +%% +%% @spec code_change(OldVsn, State, Extra) -> {ok, NewState} +%% @end +%%-------------------------------------------------------------------- +-spec(code_change(OldVsn :: term() | {down, term()}, State :: #state{}, + Extra :: term()) -> + {ok, NewState :: #state{}} | {error, Reason :: term()}). +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== +%% @private +process_match({{_}, _, _}, _, _) -> false; %skip support functors +process_match(Functor, Execute, {detailed, Functor}) -> + Execute(); +process_match(_, _, {detailed, _}) -> + false; +process_match(Functor, Execute, {arity, Pred}) -> + case erlog_ec_support:functor(Functor) of + Pred -> Execute(); + _ -> false + end. + +%% @private +process_vars(Dict) -> + Keys = dict:fetch_keys(Dict), + {Udict, Global} = lists:foldl(fun process_var/2, {Dict, []}, Keys), + Local = dict:fold(fun process_local/3, [], Udict), + lists:append(Global, Local). + +%% @private +%% Get global var's values only. +process_var(Var, {Dict, Acc}) when is_atom(Var) -> %if global var - get its value and remove from dict + Number = dict:fetch(Var, Dict), + UDict = dict:erase(Var, Dict), %delete var + try + fetch_once(Number, UDict, Var, Acc) + catch + _:_ -> {UDict, Acc} + end; +process_var(_, Acc) -> Acc. %local vars and values should stay. + +%% @private +%% Create new local var and assign value to it. +process_local(Key, Value, Acc) -> + [{{Key}, Value} | Acc]. + +%% @private +%% Fetch var's value by number and then delete it from dictionary. +fetch_once({Number}, Dict, Var, Acc) -> fetch_once(Number, Dict, Var, Acc); +fetch_once(Number, Dict, Var, Acc) -> + Val = dict:fetch(Number, Dict), %get value + Udict = dict:erase(Number, Dict), %delete value + {Udict, [{Var, Val} | Acc]}. + +%% @private +%% Is called when code execution is stopped. Waits for user action. +process_action() -> + io:format("Select action~n"), + Order = io:get_line('| ?- '), + Listing = lists:prefix("listing", Order), + Next = lists:prefix("next", Order), + Stop = lists:prefix("stop", Order), + Spy = lists:prefix("spy", Order), + if + Listing -> listing; + Next -> process_next(Order); + Stop -> process_stop(Order); + Spy -> process_spy(Order); + true -> + io:format("Wrong action!~n"), + process_action() + end. + +select_next() -> + case io:get_line('[C\_]:') of + "C\n" -> process_action(); + _ -> skip + end. + +%% @private +process_next(Next) -> + N = Next -- "next ", + {Num, _Rest} = string:to_integer(N), + {next, Num, Num}. + +%% @private +process_pred(Pred) -> + case string:str(Pred, "/") of + 0 -> {detailed, get_detailed(Pred)}; %process detailed predicate + N -> {arity, get_arity(Pred, N)} %process pred/arity predicate + end. + +%% @private +%% Get prolog predicate from string functor(...) +-spec get_detailed(Pred :: string()) -> tuple(). +get_detailed(Pred) -> + {done, Res, _} = erlog_scan:tokens([], Pred ++ ".\n", 1), + {ok, Predicate} = erlog_parse:parse_prolog_term(Res), + Predicate. + +%% @private +%% Get tuple {Functor, Arity} from functor(...) +-spec get_arity(Pred :: string(), N :: integer()) -> tuple(). +get_arity(Pred, N) -> + {Fun, Arity} = lists:split(N, Pred), + {list_to_atom(Fun -- "/"), list_to_integer(Arity)}. + +%% @private +process_stop(Stop) -> + {stop, process_pred(Stop -- "stop \n")}. + +%% @private +process_spy(Spy) -> + {spy, process_pred(Spy -- "spy \n")}. \ No newline at end of file diff --git a/src/interface/local/erlog_local_shell.erl b/src/interface/local/erlog_local_shell.erl new file mode 100644 index 0000000..0959efb --- /dev/null +++ b/src/interface/local/erlog_local_shell.erl @@ -0,0 +1,85 @@ +%% Copyright (c) 2008-2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : erlog_shell.erl +%% Author : Robert Virding +%% Purpose : A simple Erlog shell. + +-module(erlog_local_shell). + +-export([start/0, start/1]). + +start() -> + io:fwrite("Erlog Shell V~s (abort with ^G)\n", + [erlang:system_info(version)]), + {ok, Core} = erlog:start_link([{event_h, {erlog_simple_printer, []}}]), + start_db_if_needed(), %start default ets-implementation of stand-alone database-module + server_loop(Core, normal, []). + +start(Debugger) -> + io:fwrite("Erlog Shell V~s with debugger (abort with ^G)\n", + [erlang:system_info(version)]), + {ok, Core} = erlog:start_link( + [ + {event_h, {erlog_simple_printer, []}}, + {debugger, fun(Status, Functor, Result) -> gen_server:call(Debugger, {Status, Functor, Result}, infinity) end}]), + start_db_if_needed(), %start default ets-implementation of stand-alone database-module + server_loop(Core, normal, []). + +%% A simple Erlog shell similar to a "normal" Prolog shell. It allows +%% user to enter goals, see resulting bindings and request next +%% solution. +server_loop(Core, State, Line) -> + Term = io:get_line('| ?- '), + Res = case State of + select -> erlog:select(Core, lists:append(Line, Term)); + _ -> erlog:execute(Core, lists:append(Line, Term), infinity) + end, + {NewState, NewLine} = process_execute(Res, State, Line, Term), + case Term of + "halt.\n" -> ok; + _ -> server_loop(Core, NewState, NewLine) + end. + +%% Processes return value after execution. +-spec process_execute(tuple(), atom(), list(), string()) -> tuple(). +process_execute({ok, more}, State, Line, Command) -> + {State, lists:append(Line, Command)}; +process_execute({ok, halt}, _, _, _) -> + io:format("OK."), + exit(normal); +process_execute(Reply, _, _, _) -> + process_reply(Reply). + +%% Processes reply from prolog. Form it to normal view. +-spec process_reply(tuple()) -> tuple(). +process_reply({Res, select}) -> + print_res(Res), + {select, []}; +process_reply(Res) -> + print_res(Res), + {normal, []}. + +print_res({Bool, Bindings}) -> + io:format("~p~n", [Bool]), + lists:foreach(fun({Var, Value}) -> io:format("~p = ~p~n", [Var, Value]) end, Bindings); +print_res(Res) -> + io:format("~p~n", [Res]). + +start_db_if_needed() -> + case whereis(erlog_db_storage) of + undefined -> + {ok, _} = erlog_db_storage:start_link(); + _ -> ok + end. \ No newline at end of file diff --git a/src/interface/remote/erlog_remote_eh.erl b/src/interface/remote/erlog_remote_eh.erl new file mode 100644 index 0000000..68aaff5 --- /dev/null +++ b/src/interface/remote/erlog_remote_eh.erl @@ -0,0 +1,160 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 10. Июль 2014 13:46 +%%%------------------------------------------------------------------- +-module(erlog_remote_eh). +-author("tihon"). + +-behaviour(gen_event). + +%% API +-export([start_link/0, + add_handler/0]). + +%% gen_event callbacks +-export([init/1, + handle_event/2, + handle_call/2, + handle_info/2, + terminate/2, + code_change/3]). + +-define(SERVER, ?MODULE). + +-record(state, {socket}). + +%%%=================================================================== +%%% gen_event callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @doc +%% Creates an event manager +%% +%% @end +%%-------------------------------------------------------------------- +-spec(start_link() -> {ok, pid()} | {error, {already_started, pid()}}). +start_link() -> + gen_event:start_link({local, ?SERVER}). + +%%-------------------------------------------------------------------- +%% @doc +%% Adds an event handler +%% +%% @end +%%-------------------------------------------------------------------- +-spec(add_handler() -> ok | {'EXIT', Reason :: term()} | term()). +add_handler() -> + gen_event:add_handler(?SERVER, ?MODULE, []). + +%%%=================================================================== +%%% gen_event callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever a new event handler is added to an event manager, +%% this function is called to initialize the event handler. +%% +%% @end +%%-------------------------------------------------------------------- +-spec(init(InitArgs :: term()) -> + {ok, State :: #state{}} | + {ok, State :: #state{}, hibernate} | + {error, Reason :: term()}). +init(Socket) -> + {ok, #state{socket = Socket}}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever an event manager receives an event sent using +%% gen_event:notify/2 or gen_event:sync_notify/2, this function is +%% called for each installed event handler to handle the event. +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_event(Event :: term(), State :: #state{}) -> + {ok, NewState :: #state{}} | + {ok, NewState :: #state{}, hibernate} | + {swap_handler, Args1 :: term(), NewState :: #state{}, + Handler2 :: (atom() | {atom(), Id :: term()}), Args2 :: term()} | + remove_handler). +handle_event(Event, State = #state{socket = Socket}) -> + gen_tcp:send(Socket, Event), + {ok, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever an event manager receives a request sent using +%% gen_event:call/3,4, this function is called for the specified +%% event handler to handle the request. +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_call(Request :: term(), State :: #state{}) -> + {ok, Reply :: term(), NewState :: #state{}} | + {ok, Reply :: term(), NewState :: #state{}, hibernate} | + {swap_handler, Reply :: term(), Args1 :: term(), NewState :: #state{}, + Handler2 :: (atom() | {atom(), Id :: term()}), Args2 :: term()} | + {remove_handler, Reply :: term()}). +handle_call(_Request, State) -> + Reply = ok, + {ok, Reply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% This function is called for each installed event handler when +%% an event manager receives any other message than an event or a +%% synchronous request (or a system message). +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_info(Info :: term(), State :: #state{}) -> + {ok, NewState :: #state{}} | + {ok, NewState :: #state{}, hibernate} | + {swap_handler, Args1 :: term(), NewState :: #state{}, + Handler2 :: (atom() | {atom(), Id :: term()}), Args2 :: term()} | + remove_handler). +handle_info(_Info, State) -> + {ok, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever an event handler is deleted from an event manager, this +%% function is called. It should be the opposite of Module:init/1 and +%% do any necessary cleaning up. +%% +%% @spec terminate(Reason, State) -> void() +%% @end +%%-------------------------------------------------------------------- +-spec(terminate(Args :: (term() | {stop, Reason :: term()} | stop | +remove_handler | {error, {'EXIT', Reason :: term()}} | +{error, term()}), State :: term()) -> term()). +terminate(_Arg, _State) -> + ok. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Convert process state when code is changed +%% +%% @end +%%-------------------------------------------------------------------- +-spec(code_change(OldVsn :: term() | {down, term()}, State :: #state{}, + Extra :: term()) -> + {ok, NewState :: #state{}}). +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== diff --git a/src/interface/remote/erlog_remote_shell.erl b/src/interface/remote/erlog_remote_shell.erl new file mode 100644 index 0000000..e82361d --- /dev/null +++ b/src/interface/remote/erlog_remote_shell.erl @@ -0,0 +1,196 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% server for handling telnet (tcp, plaintext) connections. +%%% Such connecitons are used for debug purpose +%%% @end +%%% Created : 26. май 2014 20:05 +%%%------------------------------------------------------------------- +-module(erlog_remote_shell). +-author("tihon"). + +-behaviour(gen_server). + +%% API +-export([start_link/1]). + +%% gen_server callbacks +-export([init/1, + handle_call/3, + handle_cast/2, + handle_info/2, + terminate/2, + code_change/3]). + +-define(SERVER, ?MODULE). + +-record(state, +{ + socket, % client's socket + core, % erlog function + line = [], % current line (not separated with dot). + spike = normal % this is just a temporary spike, to handle erlog_shell_logic:show_bindings selection +}). + +%%%=================================================================== +%%% API +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @doc +%% Starts the server +%% +%% @end +%%-------------------------------------------------------------------- +-spec(start_link(Args :: term()) -> + {ok, Pid :: pid()} | ignore | {error, Reason :: term()}). +start_link(Args) -> gen_server:start_link(?MODULE, Args, []). + +%%%=================================================================== +%%% gen_server callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Initializes the server +%% +%% @spec init(Args) -> {ok, State} | +%% {ok, State, Timeout} | +%% ignore | +%% {stop, Reason} +%% @end +%%-------------------------------------------------------------------- +-spec(init(Args :: term()) -> + {ok, State :: #state{}} | {ok, State :: #state{}, timeout() | hibernate} | + {stop, Reason :: term()} | ignore). +init({tcp, Socket}) -> + gen_server:cast(self(), accept), + {ok, #state{socket = Socket}}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling call messages +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_call(Request :: term(), From :: {pid(), Tag :: term()}, + State :: #state{}) -> + {reply, Reply :: term(), NewState :: #state{}} | + {reply, Reply :: term(), NewState :: #state{}, timeout() | hibernate} | + {noreply, NewState :: #state{}} | + {noreply, NewState :: #state{}, timeout() | hibernate} | + {stop, Reason :: term(), Reply :: term(), NewState :: #state{}} | + {stop, Reason :: term(), NewState :: #state{}}). +handle_call(_Request, _From, State) -> + {reply, ok, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling cast messages +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_cast(Request :: term(), State :: #state{}) -> + {noreply, NewState :: #state{}} | + {noreply, NewState :: #state{}, timeout() | hibernate} | + {stop, Reason :: term(), NewState :: #state{}}). +handle_cast(accept, State = #state{socket = ListenSocket}) -> + {ok, AcceptSocket} = gen_tcp:accept(ListenSocket), + erlog_shell_sup:start_socket(), + Version = list_to_binary(erlang:system_info(version)), + gen_tcp:send(AcceptSocket, [<<<<"Erlog Shell V">>/binary, Version/binary, <<" (abort with ^G)\n| ?- ">>/binary>>]), + {ok, Pid} = erlog:start_link([{database, erlog_ets}, {event_h, {erlog_remote_eh, AcceptSocket}}]), + {noreply, State#state{socket = AcceptSocket, core = Pid}}; +handle_cast(_Request, State) -> + {noreply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling all non call/cast messages +%% +%% @spec handle_info(Info, State) -> {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} +%% @end +%%-------------------------------------------------------------------- +-spec(handle_info(Info :: timeout() | term(), State :: #state{}) -> + {noreply, NewState :: #state{}} | + {noreply, NewState :: #state{}, timeout() | hibernate} | + {stop, Reason :: term(), NewState :: #state{}}). +handle_info({tcp, _, CommandRaw}, State = #state{spike = Spike, line = Line, core = Core, socket = Socket}) -> + try call_prolog(Spike, Core, Line, CommandRaw) of + {ok, halt} -> + gen_tcp:send(Socket, <<"Ok.\n">>), + {stop, normal, State}; + {ok, more} -> + gen_tcp:send(Socket, <<"| ?- ">>), + {noreply, State#state{line = lists:append(Line, CommandRaw)}}; + Reply -> process_reply(State, Reply) + catch + _:Msg -> + gen_tcp:send(State#state.socket, io_lib:format("Error occurred: ~p~n| ? -", [Msg])), + erlang:display(erlang:get_stacktrace()), + {noreply, State#state{line = []}} + end; +handle_info({tcp_error, _}, State) -> + {stop, normal, State}; +handle_info({tcp_closed, _}, State) -> + {stop, normal, State}; +handle_info(_Info, State) -> + io:format("~p Unexpected: ~p~n", [?MODULE, _Info]), + {noreply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% This function is called by a gen_server when it is about to +%% terminate. It should be the opposite of Module:init/1 and do any +%% necessary cleaning up. When it returns, the gen_server terminates +%% with Reason. The return value is ignored. +%% +%% @spec terminate(Reason, State) -> void() +%% @end +%%-------------------------------------------------------------------- +-spec(terminate(Reason :: (normal | shutdown | {shutdown, term()} | term()), + State :: #state{}) -> term()). +terminate(_Reason, #state{socket = Socket, core = Core}) -> + gen_tcp:close(Socket), + gen_server:cast(Core, halt), + ok. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Convert process state when code is changed +%% +%% @spec code_change(OldVsn, State, Extra) -> {ok, NewState} +%% @end +%%-------------------------------------------------------------------- +-spec(code_change(OldVsn :: term() | {down, term()}, State :: #state{}, + Extra :: term()) -> + {ok, NewState :: #state{}} | {error, Reason :: term()}). +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== +call_prolog(select, Core, Line, Term) -> erlog:select(Core, lists:append(Line, Term)); +call_prolog(_, Core, Line, Term) -> erlog:execute(Core, lists:append(Line, Term)). + +% process reply from prolog +process_reply(State = #state{socket = Socket}, {_, select} = Reply) -> + io:format("Reply = ~p~n", [Reply]), + gen_tcp:send(Socket, io_lib:format("~p", [Reply])), + gen_tcp:send(Socket, <<"\n: ">>), + {noreply, State#state{spike = select, line = []}}; +process_reply(State = #state{socket = Socket}, Res) -> + io:format("Reply = ~p~n", [Res]), + gen_tcp:send(Socket, io_lib:format("~p", [Res])), + gen_tcp:send(Socket, <<"\n| ?- ">>), + {noreply, State#state{spike = normal, line = []}}. \ No newline at end of file diff --git a/src/interface/remote/erlog_shell_sup.erl b/src/interface/remote/erlog_shell_sup.erl new file mode 100644 index 0000000..95a5aed --- /dev/null +++ b/src/interface/remote/erlog_shell_sup.erl @@ -0,0 +1,81 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 26. май 2014 20:04 +%%%------------------------------------------------------------------- +-module(erlog_shell_sup). +-author("tihon"). + +-behaviour(supervisor). + +%% API +-export([start_link/0, start_socket/0]). + +%% Supervisor callbacks +-export([init/1]). + +-define(SERVER, ?MODULE). + +%%%=================================================================== +%%% API functions +%%%=================================================================== +% for console +start_socket() -> supervisor:start_child(?MODULE, []). + +%%-------------------------------------------------------------------- +%% @doc +%% Starts the supervisor +%% +%% @end +%%-------------------------------------------------------------------- +-spec(start_link() -> + {ok, Pid :: pid()} | ignore | {error, Reason :: term()}). +start_link() -> + supervisor:start_link({local, ?SERVER}, ?MODULE, []). + +%%%=================================================================== +%%% Supervisor callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever a supervisor is started using supervisor:start_link/[2,3], +%% this function is called by the new process to find out about +%% restart strategy, maximum restart frequency and child +%% specifications. +%% +%% @end +%%-------------------------------------------------------------------- +-spec(init(Args :: term()) -> + {ok, {SupFlags :: {RestartStrategy :: supervisor:strategy(), + MaxR :: non_neg_integer(), MaxT :: non_neg_integer()}, + [ChildSpec :: supervisor:child_spec()] + }} | + ignore | + {error, Reason :: term()}). +init([]) -> + {ok, Port} = application:get_env(console_port), + Opts = [{active, true}, {keepalive, true}, {packet, 0}, {reuseaddr, true}], + case gen_tcp:listen(Port, Opts) of + {ok, ListenSocket} -> + io:fwrite("~w:Listening on port ~p~n", [?MODULE, Port]), + RestartStrategy = {simple_one_for_one, 10, 60}, + Listener = {erlog_remote_shell, {erlog_remote_shell, start_link, [{tcp, ListenSocket}]}, + temporary, 2000, worker, [erlog_remote_shell]}, + spawn_link(fun start_socket/0), + {ok, {RestartStrategy, [Listener]}}; + {error, Reason} -> + io:format("Can't start server on ~p port!~nError: ~p", [Port, Reason]), + {stop, Reason}; + Other -> + io:format("Can't start server on ~p port!~nReason: ~p", [Port, Other]), + {stop, Other} + end. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== \ No newline at end of file diff --git a/src/io/erlog_file.erl b/src/io/erlog_file.erl new file mode 100644 index 0000000..9af6d12 --- /dev/null +++ b/src/io/erlog_file.erl @@ -0,0 +1,123 @@ +%% Copyright (c) 2008-2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : erlog_file.erl +%% Author : Robert Virding +%% Purpose : The Erlog file consulter. + +-module(erlog_file). + +-include("erlog.hrl"). + +-export([consult/3, reconsult/3, deconsult/3, load_library/3]). + + +%% consult(File, Database) -> +%% {ok,NewDatabase} | {error,Error} | {erlog_error,Error}. +%% reconsult(File, Database) -> +%% {ok,NewDatabase} | {error,Error} | {erlog_error,Error}. +%% Load/reload an Erlog file into the interpreter. Reloading will +%% abolish old definitons of clauses. +-spec consult(atom(), File :: string(), DbState :: #db_state{}) -> {ok, #db_state{}}. +consult(Consulter, File, DbState) -> + case Consulter:load(File) of %call erlog_file_consulter implementation + {ok, Terms} -> iterate_terms(fun consult_assert/2, DbState, Terms); + Error -> Error + end. + +%% consult to library space +-spec load_library(atom(), File :: string(), DbState :: #db_state{}) -> {ok, #db_state{}}. +load_library(Consulter, File, DbState) -> + case Consulter:load(File) of %call erlog_file_consulter implementation + {ok, Terms} -> iterate_terms(fun consult_lib/2, DbState, Terms); + Error -> Error + end. + +-spec reconsult(atom(), File :: string(), DbState :: #db_state{}) -> {ok, #db_state{}} | {error, Error :: term()}. +reconsult(Consulter, File, DbState) -> + case Consulter:load(File) of %call erlog_file_consulter implementation + {ok, Terms} -> + iterate_terms(fun reconsult_assert/2, {DbState, []}, Terms); + Error -> Error + end. + +-spec deconsult(atom(), File :: string(), DbState :: #db_state{}) -> {ok, #db_state{}}. +deconsult(Consulter, File, DbState) -> + case Consulter:load(File) of %call erlog_file_consulter implementation + {ok, Terms} -> + iterate_terms(fun deconsult_assert/2, {DbState, []}, Terms); + Error -> Error + end. + +%% @private +-spec consult_assert(Term0 :: term(), DbState :: #db_state{}) -> {ok, UDbState :: #db_state{}}. +consult_assert(Term0, Db) -> + Term1 = erlog_ed_logic:expand_term(Term0), + erlog_memory:assertz_clause(Db, Term1). + +%% @private +-spec consult_lib(Term0 :: term(), Db :: pid()) -> {ok, UDbState :: #db_state{}}. +consult_lib(Term0, Db) -> + Term1 = erlog_ed_logic:expand_term(Term0), + erlog_memory:load_extended_library(Db, Term1). + +%% @private +-spec reconsult_assert(Term0 :: term(), {Db :: #db_state{}, Seen :: list()}) -> {ok, {Db :: #db_state{}, list()}}. +reconsult_assert(Term0, {Db, Seen}) -> + Term1 = erlog_ed_logic:expand_term(Term0), + Func = functor(Term1), + case lists:member(Func, Seen) of + true -> + {_, UDb} = erlog_memory:assertz_clause(Db, Term1), + {ok, {UDb, Seen}}; + false -> + {_, Udb1} = erlog_memory:abolish_clauses(Db, Func), + {_, Udb2} = erlog_memory:assertz_clause(Udb1, Term1), + {ok, {Udb2, [Func | Seen]}} + end. + +%% @private +-spec deconsult_assert(Term0 :: term(), {Db :: pid(), Seen :: list()}) -> {ok, {Db :: #db_state{}, list()}}. +deconsult_assert(Term0, {Db, Seen}) -> + Term1 = erlog_ed_logic:expand_term(Term0), + Func = functor(Term1), + case lists:member(Func, Seen) of + true -> + {ok, {Db, Seen}}; + false -> + {_, Udb} = erlog_memory:abolish_clauses(Db, Func), + {ok, {Udb, [Func | Seen]}} + end. + +%% @private +%% consult_terms(InsertFun, Database, Terms) -> +%% {ok,NewDatabase} | {erlog_error,Error}. +%% Add terms to the database using InsertFun. Ignore directives and +%% queries. +-spec iterate_terms(fun(), any(), list()) -> {ok, #db_state{}}. +iterate_terms(Ifun, DbState, [{':-', _} | Ts]) -> + iterate_terms(Ifun, DbState, Ts); +iterate_terms(Ifun, DbState, [{'?-', _} | Ts]) -> + iterate_terms(Ifun, DbState, Ts); +iterate_terms(Ifun, DbState, [Term | Ts]) -> + case catch Ifun(Term, DbState) of + {erlog_error, E, _} -> {erlog_error, E}; + {erlog_error, E} -> {erlog_error, E}; + {_, UDbState} -> iterate_terms(Ifun, UDbState, Ts) %sometimes assertz db implementations return asserted object id instead ok + end; +iterate_terms(_, DbState, []) -> {ok, DbState}. + +%% @private +functor({':-', H, _B}) -> erlog_ec_support:functor(H); +functor(T) -> erlog_ec_support:functor(T). \ No newline at end of file diff --git a/src/io/erlog_io.erl b/src/io/erlog_io.erl new file mode 100644 index 0000000..b47a5eb --- /dev/null +++ b/src/io/erlog_io.erl @@ -0,0 +1,87 @@ +%% Copyright (c) 2008-2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : erlog_io.erl +%% Author : Robert Virding +%% Purpose : Some basic i/o functions for Erlog. +%% +%% Structures - {Functor,arg1, Arg2,...} where Functor is an atom +%% Variables - {Name} where Name is an atom or integer +%% Lists - Erlang lists +%% Atomic - Erlang constants +%% +%% There is no problem with the representation of variables as Prolog +%% functors of arity 0 are atoms. This representation is much easier +%% to test for, and create new variables with than using funny atom +%% names like '$1' (yuch!), and we need LOTS of variables. + +-module(erlog_io). + +-behaviour(erlog_file_consulter). + +-export([format_error/1, format_error/2, lookup/1, load/1]). + +-spec lookup(Directory :: string()) -> list(). +lookup(Directory) -> + case file:list_dir(Directory) of + {ok, List} -> List; + {error, enoent} -> [] + end. + +%% Read a file containing Prolog terms. This has been taken from 'io' +%% but cleaned up using try. +-spec load(File :: string()) -> {ok, [Term :: term()]} | {error, Error :: term()}. +load(File) -> + case file:open(File, [read]) of + {ok, Fd} -> + try + {ok, read_stream(Fd, 1)} + catch + throw:Term -> Term; + error:Error -> {error, {einval, Error}}; + exit:Exit -> {exit, {einval, Exit}} + after + file:close(Fd) + end; + Error -> Error + end. + +format_error(Params) -> format_error("Error", Params). +format_error(Type, Params) -> + B = lists:foldr( + fun(Param, Acc) when is_list(Param) -> + [Param | Acc]; + (Param, Acc) -> + [io_lib:format("~p", [Param]) | Acc] + end, ["\n"], [Type | Params]), + S = string:join(B, ": "), + lists:flatten(S). + + +%% @private +read_stream(Fd, L0) -> + case scan_erlog_term(Fd, '', L0) of + {ok, Toks, L1} -> + case erlog_parse:term(Toks, L0) of + {ok, end_of_file} -> []; %Prolog does this. + {ok, Term} -> [Term | read_stream(Fd, L1)]; %TODO recurstion is not tail! + {error, What} -> throw({error, What}) + end; + {error, Error, _} -> throw({error, Error}); + {eof, _} -> [] + end. + +%% @private +scan_erlog_term(Io, Prompt, Line) -> + io:request(Io, {get_until, Prompt, erlog_scan, tokens, [Line]}). \ No newline at end of file diff --git a/src/libs/external/cache/erlog_cache.erl b/src/libs/external/cache/erlog_cache.erl new file mode 100644 index 0000000..7975af9 --- /dev/null +++ b/src/libs/external/cache/erlog_cache.erl @@ -0,0 +1,64 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc local cache library. Includes functions for operating data in ets, +%%% tied to calling process (assuming calling process is erlog gen_server). +%%% +%%% @end +%%% Created : 18. Авг. 2014 21:46 +%%%------------------------------------------------------------------- +-module(erlog_cache). +-author("tihon"). + +-behaviour(erlog_exlib). + +-include("erlog_core.hrl"). +-include("erlog_cache.hrl"). + +%% API +-export([load/1, + put_2/1, + get_2/1]). + +load(DbState) -> + case get(erlog_cache) of + undefined -> + Ets = ets:new(erlog_cache, []), %TODO use smth else instead of ets. + put(erlog_cache, Ets); + _ -> ok + end, + lists:foldl(fun(Proc, UDBState) -> erlog_memory:load_native_library(UDBState, Proc) end, DbState, ?ERLOG_CACHE). + +put_2(Params = #param{goal = {put, _, _} = Goal, next_goal = Next, bindings = Bs}) -> + {put, Key, Value} = erlog_ec_support:dderef(Goal, Bs), + case erlog_ec_support:is_bound(Value) of %Value must exists + true -> case get(erlog_cache) of + undefined -> erlog_errors:fail(Params); + Ets -> + ets:insert(Ets, {Key, Value}), + erlog_ec_core:prove_body(Params#param{goal = Next}) + end; + false -> erlog_errors:fail(Params) + end. + +get_2(Params = #param{goal = {get, _, _} = Goal, bindings = Bs}) -> + {get, Key, Result} = erlog_ec_support:dderef(Goal, Bs), + case get(erlog_cache) of + undefined -> erlog_errors:fail(Params); + Ets -> check_value(ets:lookup(Ets, Key), Result, Params) + end. + + +%% @private +check_value([], _, Params) -> erlog_errors:fail(Params); +check_value([{_, Value}], Result, Params = #param{next_goal = Next, bindings = Bs0}) -> + case erlog_ec_support:is_bound(Result) of + true -> %compare value from cache with result + if Result == Value -> erlog_ec_core:prove_body(Params#param{goal = Next}); + true -> erlog_errors:fail(Params) + end; + false -> %save value from cache to result + Bs = erlog_ec_support:add_binding(Result, Value, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}) + end. + diff --git a/src/libs/external/db/erlog_db.erl b/src/libs/external/db/erlog_db.erl new file mode 100644 index 0000000..7a2e8d9 --- /dev/null +++ b/src/libs/external/db/erlog_db.erl @@ -0,0 +1,84 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 17. Июль 2014 11:18 +%%%------------------------------------------------------------------- +-module(erlog_db). +-author("tihon"). + +-include("erlog_core.hrl"). +-include("erlog_db.hrl"). + +-behaviour(erlog_exlib). + +%% API +-export([load/1, + db_assert_2/1, + db_asserta_2/1, + db_abolish_2/1, + db_retract_2/1, + db_retractall_2/1, + db_call_2/1, + db_listing_2/1, + db_listing_3/1, + db_listing_4/1]). + +load(DbState) -> + lists:foldl(fun(Proc, UDBState) -> erlog_memory:load_native_library(UDBState, Proc) end, DbState, ?ERLOG_DB). + +db_call_2(Param = #param{goal = {db_call, _, _} = Goal, next_goal = Next0, bindings = Bs, database = Db}) -> + {db_call, Table, G} = erlog_ec_support:dderef(Goal, Bs), + case erlog_memory:db_findall(Db, Table, G) of + {{cursor, Cursor, result, Result}, UDb} -> + Fun = fun(Params) -> erlog_db_logic:check_call_result(Result, Params, G, Table, Next0) end, + erlog_ec_core:run_n_close(Fun, Param#param{cursor = Cursor, database = UDb}); + {Result, UDb} -> erlog_db_logic:check_call_result(Result, Param#param{database = UDb}, G, Table, Next0) + end. + +db_assert_2(Params = #param{goal = {db_assert, _, _} = Goal, next_goal = Next, bindings = Bs, database = Db}) -> + {db_assert, Table, Fact} = erlog_ec_support:dderef(Goal, Bs), + {_, UDb} = erlog_memory:db_assertz_clause(Db, Table, Fact), + erlog_ec_core:prove_body(Params#param{goal = Next, database = UDb}). + +db_asserta_2(Params = #param{goal = {db_asserta, _, _} = Goal, next_goal = Next, bindings = Bs, database = Db}) -> + {db_asserta, Table, Fact} = erlog_ec_support:dderef(Goal, Bs), + {_, UDb} = erlog_memory:db_asserta_clause(Db, Table, Fact), + erlog_ec_core:prove_body(Params#param{goal = Next, database = UDb}). + +db_abolish_2(Params = #param{goal = {db_abolish, _, _} = Goal, next_goal = Next, bindings = Bs, database = Db}) -> + {db_abolish, Table, Fact} = erlog_ec_support:dderef(Goal, Bs), + case Fact of + {'/', N, A} when is_atom(N), is_integer(A), A > 0 -> + {_, UDb} = erlog_memory:db_abolish_clauses(Db, Table, {N, A}), + erlog_ec_core:prove_body(Params#param{goal = Next, database = UDb}); + Pi -> erlog_errors:type_error(predicate_indicator, Pi, Db) + end. + +db_retract_2(Params = #param{goal = {db_retract, _, _} = Goal, bindings = Bs}) -> + {db_retract, Table, Fact} = erlog_ec_support:dderef(Goal, Bs), + erlog_db_logic:prove_retract(Fact, Table, Params). + +db_retractall_2(Params = #param{goal = {db_retractall, _, _} = Goal, bindings = Bs}) -> + {db_retractall, Table, Fact} = erlog_ec_support:dderef(Goal, Bs), + erlog_db_logic:prove_retractall(Fact, Table, Params). + +db_listing_2(Params = #param{goal = {db_listing, _, _} = Goal, next_goal = Next, bindings = Bs0, database = Db}) -> + {db_listing, Table, Res} = erlog_ec_support:dderef(Goal, Bs0), + {Content, UDb} = erlog_memory:db_listing(Db, Table, []), + Bs = erlog_ec_support:add_binding(Res, Content, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs, database = UDb}). + +db_listing_3(Params = #param{goal = {db_listing, _, _, _} = Goal, next_goal = Next, bindings = Bs0, database = Db}) -> + {db_listing, Table, Functor, Res} = erlog_ec_support:dderef(Goal, Bs0), + {Content, UDb} = erlog_memory:db_listing(Db, Table, [Functor]), + Bs = erlog_ec_support:add_binding(Res, Content, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs, database = UDb}). + +db_listing_4(Params = #param{goal = {db_listing, _, _, _, _} = Goal, next_goal = Next, bindings = Bs0, database = Db}) -> + {db_listing, Table, Functor, Arity, Res} = erlog_ec_support:dderef(Goal, Bs0), + {Content, UDb} = erlog_memory:db_listing(Db, Table, [Functor, Arity]), + Bs = erlog_ec_support:add_binding(Res, Content, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs, database = UDb}). \ No newline at end of file diff --git a/src/libs/external/db/erlog_db_logic.erl b/src/libs/external/db/erlog_db_logic.erl new file mode 100644 index 0000000..0db313e --- /dev/null +++ b/src/libs/external/db/erlog_db_logic.erl @@ -0,0 +1,137 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 29. Нояб. 2014 1:59 +%%%------------------------------------------------------------------- +-module(erlog_db_logic). +-author("tihon"). + +-include("erlog_core.hrl"). + +%% API +-export([check_call_result/5, prove_retract/3, prove_retractall/3, fail_retract/2, fail_goal_clauses/2, prove_call/5]). + +prove_retract({':-', H, B}, Table, Params) -> + prove_retract(H, B, Table, Params); +prove_retract(H, Table, Params) -> + prove_retract(H, true, Table, Params). + +prove_retractall({':-', H, B}, Table, Params) -> + prove_retractall(H, B, Table, Params); +prove_retractall(H, Table, Params) -> + prove_retractall(H, true, Table, Params). + +fail_retract(#cp{data = {Ch, Cb, {Db, Cursor}, Table}, next = Next, bs = Bs, vn = Vn}, Param) -> + {{UCursor, Res}, UDb} = erlog_memory:db_next(Db, Cursor, Table), + retract_clauses(Ch, Cb, Res, Param#param{next_goal = Next, bindings = Bs, var_num = Vn, cursor = UCursor, database = UDb}, Table). + +fail_goal_clauses(#cp{data = {G, Db, Table, Cursor}, next = Next, bs = Bs, vn = Vn}, Param) -> + {{UCursor, Res}, UDb} = erlog_memory:db_next(Db, Cursor, Table), + prove_goal_clauses(Res, Table, Param#param{goal = G, next_goal = Next, bindings = Bs, var_num = Vn, cursor = UCursor, database = UDb}). + +check_call_result([], Param, _, _, _) -> erlog_errors:fail(Param); +check_call_result({clauses, Cs}, Param, G, Table, Next) -> prove_call(G, Cs, Next, Table, Param); +check_call_result({erlog_error, E}, #param{database = Db}, _, _, _) -> erlog_errors:erlog_error(E, Db); +check_call_result(Cs, Param, G, Table, Next) -> prove_call(G, Cs, Next, Table, Param). + +%% prove_goal_clauses(Goal, Clauses, Next, ChoicePoints, Bindings, VarNum, Database) -> +%% void. +%% Try to prove Goal using Clauses which all have the same functor. +prove_goal_clauses([], _, Params) -> %end of checking clauses + erlog_errors:fail(Params); +prove_goal_clauses([C], _, Params = #param{choice = Cps, var_num = Vn}) -> %for clauses with body + %% Must be smart here and test whether we need to add a cut point. + %% C has the structure {Tag,Head,{Body,BodyHasCut}}. + case element(2, element(3, C)) of + true -> + Cut = #cut{label = Vn}, + erlog_ec_core:prove_goal_clause(C, Params#param{choice = [Cut | Cps]}); + false -> + erlog_ec_core:prove_goal_clause(C, Params) + end; +prove_goal_clauses(C, Table, Params = #param{goal = G, next_goal = Next, var_num = Vn, bindings = Bs, choice = Cps, database = Db, cursor = Cursor}) -> + Cp = #cp{type = db_goal_clauses, label = Vn, data = {G, Db, Table, Cursor}, next = Next, bs = Bs, vn = Vn}, + erlog_ec_core:prove_goal_clause(C, Params#param{choice = [Cp | Cps]}). + +prove_call(G, Cs, Next0, Table, Param = #param{bindings = Bs, choice = Cps, database = Db, var_num = Vn}) -> + case erlog_ec_logic:check_goal(G, Next0, Bs, Db, false, Vn) of + {[Next1 | _], true} -> + %% Must increment Vn to avoid clashes!!! + Cut = #cut{label = Vn}, + prove_goal_clauses(Cs, Table, Param#param{goal = Next1, choice = [Cut | Cps], var_num = Vn + 1}); + {[Next1 | _], false} -> prove_goal_clauses(Cs, Table, Param#param{goal = Next1, var_num = Vn + 1}) + end. + + +%% @private +prove_retract(H, B, Table, Params = #param{database = Db}) -> + case erlog_memory:get_db_procedure(Db, Table, H) of + {{cursor, Cursor, result, {clauses, Cs}}, UDB} -> + erlog_ec_core:run_n_close(fun(Param) -> + retract_clauses(H, B, Cs, Param, Table) end, Params#param{cursor = Cursor, database = UDB}); + {undefined, UDB} -> erlog_errors:fail(Params#param{database = UDB}); + _ -> + Functor = erlog_ec_support:functor(H), + erlog_errors:permission_error(modify, static_procedure, erlog_ec_support:pred_ind(Functor)) + end. + +%% @private +prove_retractall(H, B, Table, Params = #param{database = Db}) -> + Functor = erlog_ec_support:functor(H), + case erlog_memory:get_db_procedure(Db, Table, H) of + {{cursor, Cursor, result, Res}, UDb} -> + check_retractall_result(Res, H, B, Functor, Table, Params#param{cursor = Cursor, database = UDb}); + {Res, UDb} -> + check_retractall_result(Res, H, B, Functor, Table, Params#param{database = UDb}) + end. + +%% @private +retract(Ch, Cb, C, Cursor, Param = #param{next_goal = Next, choice = Cps, bindings = Bs0, var_num = Vn0, database = Db}, Bs1, Vn1, Table) -> + {_, UDb} = erlog_memory:db_retract_clause(Db, Table, erlog_ec_support:functor(Ch), element(1, C)), + Cp = #cp{type = db_retract, data = {Ch, Cb, {UDb, Cursor}, Table}, next = Next, bs = Bs0, vn = Vn0}, + erlog_ec_core:prove_body(Param#param{goal = Next, choice = [Cp | Cps], bindings = Bs1, var_num = Vn1, database = UDb}). + +%% @private +%% retract_clauses(Head, Body, Clauses, Next, ChoicePoints, Bindings, VarNum, Database) -> +%% void. +%% Try to retract Head and Body using Clauses which all have the same functor. +retract_clauses(_, _, [], Param, _) -> erlog_errors:fail(Param); +retract_clauses(Ch, Cb, [C], Param, Table) -> retract_clauses(Ch, Cb, C, Param, Table); +retract_clauses(Ch, Cb, C, Param = #param{bindings = Bs0, var_num = Vn0, database = Db, cursor = Cursor}, Table) -> + case erlog_ec_unify:unify_clause(Ch, Cb, C, Bs0, Vn0) of + {succeed, Bs1, Vn1} -> + %% We have found a right clause so now retract it. + retract(Ch, Cb, C, Cursor, Param, Bs1, Vn1, Table); + fail -> + {{UCursor, Res}, UDb} = erlog_memory:db_next(Db, Cursor, Table), + retract_clauses(Ch, Cb, Res, Param#param{cursor = UCursor, database = UDb}, Table) + end. + +%% @private +retractall_clauses(_, [], _, _, Params = #param{next_goal = Next}) -> + erlog_ec_core:prove_body(Params#param{goal = Next}); +retractall_clauses(Table, [Clause], H, B, Params) -> retractall_clauses(Table, Clause, H, B, Params); +retractall_clauses(Table, Clause, H, B, Params = #param{bindings = Bs0, var_num = Vn0, database = Db, cursor = Cursor}) -> + case erlog_ec_unify:unify_clause(H, B, Clause, Bs0, Vn0) of + {succeed, _, _} -> + {{UCursor, Res}, UDb} = erlog_memory:db_retract_clause(Db, Table, erlog_ec_support:functor(H), element(1, Clause)), + {{UCursor, Res}, UDb2} = erlog_memory:db_next(UDb, Cursor, Table), + retractall_clauses(Table, Res, H, B, Params#param{cursor = UCursor, database = UDb2}); + fail -> + retractall_clauses(Table, [], H, B, Params) + end. + +%% @private +check_retractall_result({built_in, _}, _, _, Functor, _, _) -> + erlog_errors:permission_error(modify, static_procedure, erlog_ec_support:pred_ind(Functor)); +check_retractall_result({code, _}, _, _, Functor, _, _) -> + erlog_errors:permission_error(modify, static_procedure, erlog_ec_support:pred_ind(Functor)); +check_retractall_result({clauses, Cs}, H, B, _, Table, Params = #param{cursor = Cursor}) -> + Fun = fun(Param) -> retractall_clauses(Table, Cs, H, B, Param) end, + erlog_ec_core:run_n_close(Fun, Params#param{cursor = Cursor}); +check_retractall_result(undefined, _, _, _, _, Params = #param{next_goal = Next}) -> + erlog_ec_core:prove_body(Params#param{goal = Next}); +check_retractall_result({erlog_error, E}, _, _, _, _, #param{database = Db}) -> erlog_errors:erlog_error(E, Db). \ No newline at end of file diff --git a/src/libs/external/db/erlog_db_storage.erl b/src/libs/external/db/erlog_db_storage.erl new file mode 100644 index 0000000..89ab09a --- /dev/null +++ b/src/libs/external/db/erlog_db_storage.erl @@ -0,0 +1,169 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% Default implementation of standalone database. For test purposes of +%%% operating facts with another db. It goes as an extencion of erlog_ets. +%%% @end +%%% Created : 22. Июль 2014 0:49 +%%%------------------------------------------------------------------- +-module(erlog_db_storage). +-author("tihon"). + +-behaviour(gen_server). + +%% API +-export([start_link/0, get_db/2, update_db/2]). + +%% gen_server callbacks +-export([init/1, + handle_call/3, + handle_cast/2, + handle_info/2, + terminate/2, + code_change/3]). + +-define(SERVER, ?MODULE). + +-record(state, +{ + memory = [] :: dict +}). + +%%%=================================================================== +%%% API +%%%=================================================================== +-spec get_db(atom(), atom()) -> ets. +get_db(Type, Collection) -> gen_server:call(?MODULE, {get_db, Type, Collection}). + +update_db(Collection, Db) -> gen_server:call(?MODULE, {update_db, Collection, Db}). +%%-------------------------------------------------------------------- +%% @doc +%% Starts the server +%% +%% @end +%%-------------------------------------------------------------------- +-spec(start_link() -> + {ok, Pid :: pid()} | ignore | {error, Reason :: term()}). +start_link() -> + gen_server:start_link({local, ?SERVER}, ?MODULE, [], []). + +%%%=================================================================== +%%% gen_server callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Initializes the server +%% +%% @spec init(Args) -> {ok, State} | +%% {ok, State, Timeout} | +%% ignore | +%% {stop, Reason} +%% @end +%%-------------------------------------------------------------------- +-spec(init(Args :: term()) -> + {ok, State :: #state{}} | {ok, State :: #state{}, timeout() | hibernate} | + {stop, Reason :: term()} | ignore). +init([]) -> + {ok, #state{memory = dict:new()}}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling call messages +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_call(Request :: term(), From :: {pid(), Tag :: term()}, + State :: #state{}) -> + {reply, Reply :: term(), NewState :: #state{}} | + {reply, Reply :: term(), NewState :: #state{}, timeout() | hibernate} | + {noreply, NewState :: #state{}} | + {noreply, NewState :: #state{}, timeout() | hibernate} | + {stop, Reason :: term(), Reply :: term(), NewState :: #state{}} | + {stop, Reason :: term(), NewState :: #state{}}). +handle_call({get_db, ets, Collection}, _From, State = #state{memory = Dbs}) -> + {Ets, Memory} = get_db(Collection, fun() -> ets:new(Collection, [public]) end, Dbs), + {reply, Ets, State#state{memory = Memory}}; +handle_call({get_db, dict, Collection}, _From, State = #state{memory = Dbs}) -> + {Dict, Memory} = get_db(Collection, fun() -> dict:new() end, Dbs), + {reply, Dict, State#state{memory = Memory}}; +handle_call({update_db, Collection, Db}, _From, State = #state{memory = Dbs}) -> + Umemory = dict:store(Collection, Db, Dbs), + {reply, ok, State#state{memory = Umemory}}; +handle_call(_Request, _From, State) -> + {reply, ok, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling cast messages +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_cast(Request :: term(), State :: #state{}) -> + {noreply, NewState :: #state{}} | + {noreply, NewState :: #state{}, timeout() | hibernate} | + {stop, Reason :: term(), NewState :: #state{}}). +handle_cast(_Request, State) -> + {noreply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Handling all non call/cast messages +%% +%% @spec handle_info(Info, State) -> {noreply, State} | +%% {noreply, State, Timeout} | +%% {stop, Reason, State} +%% @end +%%-------------------------------------------------------------------- +-spec(handle_info(Info :: timeout() | term(), State :: #state{}) -> + {noreply, NewState :: #state{}} | + {noreply, NewState :: #state{}, timeout() | hibernate} | + {stop, Reason :: term(), NewState :: #state{}}). +handle_info(_Info, State) -> + {noreply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% This function is called by a gen_server when it is about to +%% terminate. It should be the opposite of Module:init/1 and do any +%% necessary cleaning up. When it returns, the gen_server terminates +%% with Reason. The return value is ignored. +%% +%% @spec terminate(Reason, State) -> void() +%% @end +%%-------------------------------------------------------------------- +-spec(terminate(Reason :: (normal | shutdown | {shutdown, term()} | term()), + State :: #state{}) -> term()). +terminate(_Reason, _State) -> + ok. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Convert process state when code is changed +%% +%% @spec code_change(OldVsn, State, Extra) -> {ok, NewState} +%% @end +%%-------------------------------------------------------------------- +-spec(code_change(OldVsn :: term() | {down, term()}, State :: #state{}, + Extra :: term()) -> + {ok, NewState :: #state{}} | {error, Reason :: term()}). +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== +get_db(Collection, CreateFun, Dbs) -> + case dict:find(Collection, Dbs) of + error -> + Db = CreateFun(), + {Db, dict:store(Collection, Db, Dbs)}; + {ok, Db} -> {Db, Dbs} + end. \ No newline at end of file diff --git a/src/libs/external/erlog_exlib.erl b/src/libs/external/erlog_exlib.erl new file mode 100644 index 0000000..007a8b1 --- /dev/null +++ b/src/libs/external/erlog_exlib.erl @@ -0,0 +1,15 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc erlog external library interface +%%% +%%% @end +%%% Created : 15. Авг. 2014 14:28 +%%%------------------------------------------------------------------- +-module(erlog_exlib). +-author("tihon"). + +-include("erlog.hrl"). + +%% load database to library space +-callback load(Db :: #db_state{}) -> #db_state{}. \ No newline at end of file diff --git a/src/libs/standard/bips/logic/erlog_eb_logic.erl b/src/libs/standard/bips/logic/erlog_eb_logic.erl new file mode 100644 index 0000000..e97115f --- /dev/null +++ b/src/libs/standard/bips/logic/erlog_eb_logic.erl @@ -0,0 +1,200 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 12. Авг. 2014 17:24 +%%%------------------------------------------------------------------- +-module(erlog_eb_logic). +-author("tihon"). + +-include("erlog_core.hrl"). + +%% API +-export([term_test_prove_body/4, + prove_arg/4, + prove_functor/4, + prove_univ/3, + prove_atom_chars/3, + arith_test_prove_body/4, eval_arith/3]). + +%% term_test_prove_body(Test, Left, Right, Next, ChoicePoints, Bindings, Varnum, Database) -> +%% void. +term_test_prove_body(Test, L, R, Params = #param{next_goal = Next, bindings = Bs}) -> + case erlang:Test(erlog_ec_support:dderef(L, Bs), erlog_ec_support:dderef(R, Bs)) of + true -> erlog_ec_core:prove_body(Params#param{goal = Next}); + false -> erlog_errors:fail(Params) + end. + +%% prove_arg(Index, Term, Arg, Next, ChoicePoints, VarNum, Database) -> void. +%% Prove the goal arg(I, Ct, Arg), Index and Term have been dereferenced. +prove_arg(I, [H | T], A, Param = #param{database = Db}) when is_integer(I) -> + if + I == 1 -> erlog_ec_body:unify_prove_body(H, A, Param); + I == 2 -> erlog_ec_body:unify_prove_body(T, A, Param); + true -> {fail, Db} + end; +prove_arg(I, Ct, A, Param = #param{database = Db}) + when is_integer(I), tuple_size(Ct) >= 2 -> + if I > 1, I + 1 =< tuple_size(Ct) -> + erlog_ec_body:unify_prove_body(element(I + 1, Ct), A, Param); + true -> {fail, Db} + end; +prove_arg(I, Ct, _, #param{database = Db}) -> + %%Type failure just generates an error. + if not(is_integer(I)) -> erlog_errors:type_error(integer, I, Db); + true -> erlog_errors:type_error(compound, Ct, Db) + end. + +%% prove_functor(Term, Functor, Arity, Next, ChoicePoints, Bindings, VarNum, Database) -> void. +%% Prove the call functor(T, F, A), Term has been dereferenced. +prove_functor(T, F, A, Params) when tuple_size(T) >= 2 -> + erlog_ec_body:unify_prove_body(F, element(1, T), A, tuple_size(T) - 1, Params); +prove_functor(T, F, A, Params) when ?IS_ATOMIC(T) -> + erlog_ec_body:unify_prove_body(F, T, A, 0, Params); +prove_functor([_ | _], F, A, Params) -> + %% Just the top level here. + erlog_ec_body:unify_prove_body(F, '.', A, 2, Params); +prove_functor({_} = Var, F0, A0, Params = #param{next_goal = Next, bindings = Bs0, var_num = Vn0, database = Db}) -> + case {erlog_ec_support:dderef(F0, Bs0), erlog_ec_support:dderef(A0, Bs0)} of + {'.', 2} -> %He, he, he! + Bs1 = erlog_ec_support:add_binding(Var, [{Vn0} | {Vn0 + 1}], Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1, var_num = Vn0 + 2}); + {F1, 0} when ?IS_ATOMIC(F1) -> + Bs1 = erlog_ec_support:add_binding(Var, F1, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}); + {F1, A1} when is_atom(F1), is_integer(A1), A1 > 0 -> + As = erlog_ec_support:make_vars(A1, Vn0), + Bs1 = erlog_ec_support:add_binding(Var, list_to_tuple([F1 | As]), Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1, var_num = Vn0 + A1}); %!!! + %% Now the error cases. + {{_}, _} -> erlog_errors:instantiation_error(Db); + {F1, A1} when is_atom(F1) -> erlog_errors:type_error(integer, A1, Db); + {F1, _} -> erlog_errors:type_error(atom, F1, Db) + end. + +%% prove_univ(Term, List, Next, ChoicePoints, Bindings, VarNum, Database) -> void. +%% Prove the goal Term =.. List, Term has already been dereferenced. +prove_univ(T, L, Params) when tuple_size(T) >= 2 -> + Es = tuple_to_list(T), + erlog_ec_body:unify_prove_body(Es, L, Params); +prove_univ(T, L, Params) when ?IS_ATOMIC(T) -> + erlog_ec_body:unify_prove_body([T], L, Params); +prove_univ([Lh | Lt], L, Params) -> + erlog_ec_body:unify_prove_body(['.', Lh, Lt], L, Params); +prove_univ({_} = Var, L, Params = #param{next_goal = Next, bindings = Bs0, database = Db}) -> + Bs1 = case erlog_ec_support:dderef(L, Bs0) of + ['.', Lh, Lt] -> %He, he, he! + erlog_ec_support:add_binding(Var, [Lh | Lt], Bs0); + [A] when ?IS_ATOMIC(A) -> + erlog_ec_support:add_binding(Var, A, Bs0); + [F | As] when is_atom(F), length(As) > 0 -> + erlog_ec_support:add_binding(Var, list_to_tuple([F | As]), Bs0); + %% Now the error cases. They end with throw -> no return there + [{_} | _] -> erlog_errors:instantiation_error(Db); + {_} -> erlog_errors:instantiation_error(Db); + Other -> erlog_errors:type_error(list, Other, Db) + end, + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}). + +%% prove_atom_chars(Atom, List, Next, ChoicePoints, Bindings, VarNum, Database) -> +%% void. +%% Prove the atom_chars(Atom, List). +prove_atom_chars(A, L, Params = #param{bindings = Bs, database = Db}) -> + %% After a suggestion by Sean Cribbs. + case erlog_ec_support:dderef(A, Bs) of + Atom when is_atom(Atom) -> + AtomList = [list_to_atom([C]) || C <- atom_to_list(Atom)], + erlog_ec_body:unify_prove_body(L, AtomList, Params); + {_} = Var -> + %% Error #3: List is neither a list nor a partial list. + %% Handled in dderef_list/2. + List = erlog_ec_support:dderef_list(L, Bs), + %% Error #1, #4: List is a list or partial list with an + %% element which is a variable or not one char atom. + Fun = fun({_}) -> erlog_errors:instantiation_error(Db); + (Atom) -> + case is_atom(Atom) andalso atom_to_list(Atom) of + [C] -> C; + _ -> erlog_errors:type_error(character, Atom, Db) + end + end, + Chars = lists:map(Fun, List), + Atom = list_to_atom(Chars), + erlog_ec_body:unify_prove_body(Var, Atom, Params); + Other -> + %% Error #2: Atom is neither a variable nor an atom + erlog_errors:type_error(atom, Other, Db) + end. + +%% arith_test_prove_body(Test, Left, Right, Next, ChoicePoints, Bindings, VarNum, Database) -> +%% void. +arith_test_prove_body(Test, L, R, Params = #param{next_goal = Next, bindings = Bs, database = Db}) -> + case erlang:Test(eval_arith(erlog_ec_support:deref(L, Bs), Bs, Db), + eval_arith(erlog_ec_support:deref(R, Bs), Bs, Db)) of + true -> erlog_ec_core:prove_body(Params#param{goal = Next}); + false -> erlog_errors:fail(Params) + end. + +%% eval_arith(ArithExpr, Bindings, Database) -> Number. +%% Evaluate an arithmetic expression, include the database for +%% errors. Dereference each level as we go, might fail so save some +%% work. Must be called deferenced. +eval_arith({'+', A, B}, Bs, Db) -> + eval_arith(erlog_ec_support:deref(A, Bs), Bs, Db) + eval_arith(erlog_ec_support:deref(B, Bs), Bs, Db); +eval_arith({'-', A, B}, Bs, Db) -> + eval_arith(erlog_ec_support:deref(A, Bs), Bs, Db) - eval_arith(erlog_ec_support:deref(B, Bs), Bs, Db); +eval_arith({'*', A, B}, Bs, Db) -> + eval_arith(erlog_ec_support:deref(A, Bs), Bs, Db) * eval_arith(erlog_ec_support:deref(B, Bs), Bs, Db); +eval_arith({'/', A, B}, Bs, Db) -> + eval_arith(erlog_ec_support:deref(A, Bs), Bs, Db) / eval_arith(erlog_ec_support:deref(B, Bs), Bs, Db); +eval_arith({'**', A, B}, Bs, Db) -> + math:pow(eval_arith(erlog_ec_support:deref(A, Bs), Bs, Db), + eval_arith(erlog_ec_support:deref(B, Bs), Bs, Db)); +eval_arith({'//', A, B}, Bs, Db) -> + eval_int(erlog_ec_support:deref(A, Bs), Bs, Db) div eval_int(erlog_ec_support:deref(B, Bs), Bs, Db); +eval_arith({'mod', A, B}, Bs, Db) -> + eval_int(erlog_ec_support:deref(A, Bs), Bs, Db) rem eval_int(erlog_ec_support:deref(B, Bs), Bs, Db); +eval_arith({'/\\', A, B}, Bs, Db) -> + eval_int(erlog_ec_support:deref(A, Bs), Bs, Db) band eval_int(erlog_ec_support:deref(B, Bs), Bs, Db); +eval_arith({'\\/', A, B}, Bs, Db) -> + eval_int(erlog_ec_support:deref(A, Bs), Bs, Db) bor eval_int(erlog_ec_support:deref(B, Bs), Bs, Db); +eval_arith({'<<', A, B}, Bs, Db) -> + eval_int(erlog_ec_support:deref(A, Bs), Bs, Db) bsl eval_int(erlog_ec_support:deref(B, Bs), Bs, Db); +eval_arith({'>>', A, B}, Bs, Db) -> + eval_int(erlog_ec_support:deref(A, Bs), Bs, Db) bsr eval_int(erlog_ec_support:deref(B, Bs), Bs, Db); +eval_arith({'\\', A}, Bs, Db) -> + bnot eval_int(erlog_ec_support:deref(A, Bs), Bs, Db); +eval_arith({'+', A}, Bs, Db) -> + + eval_arith(erlog_ec_support:deref(A, Bs), Bs, Db); +eval_arith({'-', A}, Bs, Db) -> + - eval_arith(erlog_ec_support:deref(A, Bs), Bs, Db); +eval_arith({'abs', A}, Bs, Db) -> + abs(eval_arith(erlog_ec_support:deref(A, Bs), Bs, Db)); +eval_arith({'float', A}, Bs, Db) -> + float(eval_arith(erlog_ec_support:deref(A, Bs), Bs, Db)); +eval_arith({'truncate', A}, Bs, Db) -> + trunc(eval_arith(erlog_ec_support:deref(A, Bs), Bs, Db)); +eval_arith(N, _Bs, _Db) when is_number(N) -> N; %Just a number +%% Error cases. +eval_arith({_}, _Bs, Db) -> erlog_errors:instantiation_error(Db); +eval_arith(N, _Bs, Db) when is_tuple(N) -> + Pi = pred_ind(element(1, N), tuple_size(N) - 1), + erlog_errors:type_error(evaluable, Pi, Db); +eval_arith([_ | _], _Bs, Db) -> + erlog_errors:type_error(evaluable, pred_ind('.', 2), Db); +eval_arith(O, _Bs, Db) -> erlog_errors:type_error(evaluable, O, Db). + + +%% @private +%% eval_int(IntegerExpr, Bindings, Database) -> Integer. +%% Evaluate an integer expression, include the database for errors. +eval_int(E0, Bs, Db) -> + E = eval_arith(E0, Bs, Db), + if is_integer(E) -> E; + true -> erlog_errors:type_error(integer, E, Db) + end. + +%% @private +pred_ind(N, A) -> {'/', N, A}. \ No newline at end of file diff --git a/src/libs/standard/bips/main/erlog_bips.erl b/src/libs/standard/bips/main/erlog_bips.erl new file mode 100644 index 0000000..6cef8f6 --- /dev/null +++ b/src/libs/standard/bips/main/erlog_bips.erl @@ -0,0 +1,148 @@ +%% Copyright (c) 2008-2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : erlog_bips.erl +%% Author : Robert Virding +%% Purpose : Built-in predicates of Erlog interpreter. +%% +%% These are the built-in predicates of the Prolog interpreter which +%% are not control predicates or database predicates. + +-module(erlog_bips). + +-behaviour(erlog_stdlib). + +-include("erlog_core.hrl"). +-include("erlog_bips.hrl"). + +%% Main interface functions. +-export([load/1]). +-export([prove_goal/1]). + +%% load(Database) -> Database. +%% Assert predicates into the database. +load(DbState) -> + lists:foldl(fun(Head, UDBState) -> erlog_memory:load_kernel_space(UDBState, ?MODULE, Head) end, DbState, ?ERLOG_BIPS). + +%% prove_goal(Goal, NextGoal, ChoicePoints, Bindings, VarNum, Database) -> +%% {succeed,ChoicePoints,NewBindings,NewVarNum,NewDatabase} | +%% {fail,NewDatabase}. +%% Prove one goal. We seldom return succeed here but usually go directly to +%% to NextGoal. + +%% Term unification and comparison +prove_goal(Params = #param{goal = {'=', L, R}}) -> + erlog_ec_body:unify_prove_body(L, R, Params); +prove_goal(Params = #param{goal = {'\\=', L, R}, next_goal = Next, bindings = Bs0}) -> + case erlog_ec_unify:unify(L, R, Bs0) of + {succeed, _Bs1} -> erlog_errors:fail(Params); + fail -> erlog_ec_core:prove_body(Params#param{goal = Next}) + end; +prove_goal(Params = #param{goal = {'@>', L, R}}) -> + erlog_eb_logic:term_test_prove_body('>', L, R, Params); +prove_goal(Params = #param{goal = {'@>=', L, R}}) -> + erlog_eb_logic:term_test_prove_body('>=', L, R, Params); +prove_goal(Params = #param{goal = {'==', L, R}}) -> + erlog_eb_logic:term_test_prove_body('==', L, R, Params); +prove_goal(Params = #param{goal = {'\\==', L, R}}) -> + erlog_eb_logic:term_test_prove_body('/=', L, R, Params); +prove_goal(Params = #param{goal = {'@<', L, R}}) -> + erlog_eb_logic:term_test_prove_body('<', L, R, Params); +prove_goal(Params = #param{goal = {'@=<', L, R}}) -> + erlog_eb_logic:term_test_prove_body('=<', L, R, Params); +%% Term creation and decomposition. +prove_goal(Params = #param{goal = {arg, I, Ct, A}, bindings = Bs}) -> + erlog_eb_logic:prove_arg(erlog_ec_support:deref(I, Bs), erlog_ec_support:deref(Ct, Bs), A, Params); +prove_goal(Params = #param{goal = {copy_term, T0, C}, bindings = Bs, var_num = Vn0}) -> + %% Use term_instance to create the copy, can ignore orddict it creates. + {T, _Nbs, Vn1} = erlog_ec_term:term_instance(erlog_ec_support:dderef(T0, Bs), Vn0), + erlog_ec_body:unify_prove_body(T, C, Params#param{var_num = Vn1}); +prove_goal(Params = #param{goal = {functor, T, F, A}, bindings = Bs}) -> + erlog_eb_logic:prove_functor(erlog_ec_support:dderef(T, Bs), F, A, Params); +prove_goal(Params = #param{goal = {'=..', T, L}, bindings = Bs}) -> + erlog_eb_logic:prove_univ(erlog_ec_support:dderef(T, Bs), L, Params); +%% Type testing. +prove_goal(Params = #param{goal = {atom, T0}, next_goal = Next, bindings = Bs}) -> + case erlog_ec_support:deref(T0, Bs) of + T when is_atom(T) -> erlog_ec_core:prove_body(Params#param{goal = Next}); + _Other -> erlog_errors:fail(Params) + end; +prove_goal(Params = #param{goal = {atomic, T0}, next_goal = Next, bindings = Bs}) -> + case erlog_ec_support:deref(T0, Bs) of + T when ?IS_ATOMIC(T) -> erlog_ec_core:prove_body(Params#param{goal = Next}); + _Other -> erlog_errors:fail(Params) + end; +prove_goal(Params = #param{goal = {compound, T0}, next_goal = Next, bindings = Bs}) -> + case erlog_ec_support:deref(T0, Bs) of + T when ?IS_ATOMIC(T) -> erlog_errors:fail(Params); + _Other -> erlog_ec_core:prove_body(Params#param{goal = Next}) + end; +prove_goal(Params = #param{goal = {integer, T0}, next_goal = Next, bindings = Bs}) -> + case erlog_ec_support:deref(T0, Bs) of + T when is_integer(T) -> erlog_ec_core:prove_body(Params#param{goal = Next}); + _Other -> erlog_errors:fail(Params) + end; +prove_goal(Params = #param{goal = {float, T0}, next_goal = Next, bindings = Bs}) -> + case erlog_ec_support:deref(T0, Bs) of + T when is_float(T) -> erlog_ec_core:prove_body(Params#param{goal = Next}); + _Other -> erlog_errors:fail(Params) + end; +prove_goal(Params = #param{goal = {number, T0}, next_goal = Next, bindings = Bs}) -> + case erlog_ec_support:deref(T0, Bs) of + T when is_number(T) -> erlog_ec_core:prove_body(Params#param{goal = Next}); + _Other -> erlog_errors:fail(Params) + end; +prove_goal(Params = #param{goal = {nonvar, T0}, next_goal = Next, bindings = Bs}) -> + case erlog_ec_support:deref(T0, Bs) of + {_} -> erlog_errors:fail(Params); + _Other -> erlog_ec_core:prove_body(Params#param{goal = Next}) + end; +prove_goal(Params = #param{goal = {var, T0}, next_goal = Next, bindings = Bs}) -> + case erlog_ec_support:deref(T0, Bs) of + {_} -> erlog_ec_core:prove_body(Params#param{goal = Next}); + _Other -> erlog_errors:fail(Params) + end; +%% Atom processing. +prove_goal(Params = #param{goal = {atom_chars, A, L}}) -> + erlog_eb_logic:prove_atom_chars(A, L, Params); +prove_goal(Params = #param{goal = {atom_length, A0, L0}, bindings = Bs, database = Db}) -> + case erlog_ec_support:dderef(A0, Bs) of + A when is_atom(A) -> + Alen = length(atom_to_list(A)), %No of chars in atom + case erlog_ec_support:dderef(L0, Bs) of + L when is_integer(L) -> + erlog_ec_body:unify_prove_body(Alen, L, Params); + {_} = Var -> + erlog_ec_body:unify_prove_body(Alen, Var, Params); + Other -> erlog_errors:type_error(integer, Other, Db) + end; + {_} -> erlog_errors:instantiation_error(Db); + Other -> erlog_errors:type_error(atom, Other, Db) + end; +%% Arithmetic evalution and comparison. +prove_goal(Params = #param{goal = {is, N, E0}, bindings = Bs, database = Db}) -> + E = erlog_eb_logic:eval_arith(erlog_ec_support:deref(E0, Bs), Bs, Db), + erlog_ec_body:unify_prove_body(N, E, Params); +prove_goal(Params = #param{goal = {'>', L, R}}) -> + erlog_eb_logic:arith_test_prove_body('>', L, R, Params); +prove_goal(Params = #param{goal = {'>=', L, R}}) -> + erlog_eb_logic:arith_test_prove_body('>=', L, R, Params); +prove_goal(Params = #param{goal = {'=:=', L, R}}) -> + erlog_eb_logic:arith_test_prove_body('==', L, R, Params); +prove_goal(Params = #param{goal = {'=\\=', L, R}}) -> + erlog_eb_logic:arith_test_prove_body('/=', L, R, Params); +prove_goal(Params = #param{goal = {'<', L, R}}) -> + erlog_eb_logic:arith_test_prove_body('<', L, R, Params); +prove_goal(Params = #param{goal = {'=<', L, R}}) -> + erlog_eb_logic:arith_test_prove_body('=<', L, R, Params). \ No newline at end of file diff --git a/src/libs/standard/core/logic/erlog_ec_logic.erl b/src/libs/standard/core/logic/erlog_ec_logic.erl new file mode 100644 index 0000000..5c876aa --- /dev/null +++ b/src/libs/standard/core/logic/erlog_ec_logic.erl @@ -0,0 +1,274 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc core logic code of erlog_code functions +%%% +%%% @end +%%% Created : 15. Июль 2014 16:02 +%%%------------------------------------------------------------------- +-module(erlog_ec_logic). +-author("tihon"). + +-include("erlog_core.hrl"). + +%% API +-export([initial_goal/1, + check_goal/6, + prove_findall/4, + prove_ecall/3, + prove_clause/3, + prove_current_predicate/2, + prove_predicates/3, + prove_retract/2, + prove_retractall/2, + retract_clauses/4, parse_int/1, to_string/1]). + +%% prove_findall(Term, Goal, Bag, Param) +%% Do findall on Goal and return list of each Term in Bag. We are +%% sneaky here and use the database to keep the list using the +%% current VarNum as tag. This is done in the internal goal +%% {findall}. Then when findall finally fails which catch it in +%% fail_findall which cleans up by removing special database entry +%% and unifying Bag. +prove_findall(T, G, B0, Param = #param{bindings = Bs, choice = Cps, next_goal = Next, var_num = Vn, database = Db}) -> + Label = Vn, + Tag = Vn + 1, %Increment to avoid clashes + {Next1, _} = erlog_ec_logic:check_goal(G, [{findall, Tag, T}], Bs, Db, false, Label), + B1 = partial_list(B0, Bs), + Cp = #cp{type = findall, data = {Tag, B1}, next = Next, bs = Bs, vn = Vn}, + UDb = erlog_memory:raw_store(Db, Tag, []), %Initialise collection + %% Catch case where an erlog error occurs when cleanup database. + try + erlog_ec_core:prove_body(Param#param{goal = Next1, choice = [Cp | Cps], bindings = Bs, var_num = Vn + 1, database = UDb}) + catch + throw:{erlog_error, E, Dba} -> + Dbb = erlog_memory:raw_erase(Dba, Tag), %Clear special entry + erlog_errors:erlog_error(E, Dbb) + end. + +%% prove_ecall(Generator, Value, Next, ChoicePoints, Bindings, VarNum, Database) -> +%% void. +%% Call an external (Erlang) generator and handle return value, either +%% succeed or fail. +prove_ecall(Efun, Val, Param = #param{next_goal = Next, choice = Cps, bindings = Bs, var_num = Vn}) -> + case Efun() of + {succeed, Ret, Cont} -> %Succeed and more choices + Cp = #cp{type = ecall, data = {Cont, Val}, next = Next, bs = Bs, vn = Vn}, + erlog_ec_body:unify_prove_body(Val, Ret, Param#param{choice = [Cp | Cps]}); + {succeed_last, Ret} -> %Succeed but last choice + erlog_ec_body:unify_prove_body(Val, Ret, Param); + fail -> erlog_errors:fail(Param) %No more + end. + +%% prove_clause(Head, Body, Next, ChoicePoints, Bindings, VarNum, DataBase) -> +%% void. +%% Unify clauses matching with functor from Head with both Head and Body. +prove_clause(H, B, Params = #param{database = Db}) -> + Functor = erlog_ec_support:functor(H), + {Res, UDb} = erlog_memory:get_procedure(Db, H), + case Res of + {cursor, Cursor, result, {clauses, Cs}} -> + erlog_ec_core:run_n_close(fun(Param) -> erlog_ec_unify:unify_clauses(H, B, Cs, Param) end, + Params#param{cursor = Cursor, database = UDb}); + {code, _} -> + erlog_errors:permission_error(access, private_procedure, erlog_ec_support:pred_ind(Functor)); + built_in -> + erlog_errors:permission_error(access, private_procedure, erlog_ec_support:pred_ind(Functor)); + undefined -> erlog_errors:fail(Params#param{database = UDb}) + end. + +%% prove_current_predicate(PredInd, Next, ChoicePoints, Bindings, VarNum, DataBase) -> +%% void. +%% Match functors of existing user (interpreted) predicate with PredInd. +prove_current_predicate(Pi, Param = #param{database = Db}) -> + case Pi of + {'/', _, _} -> ok; + {_} -> ok; + Other -> erlog_errors:type_error(predicate_indicator, Other) + end, + {Fs, UDb} = erlog_memory:get_interp_functors(Db), + prove_predicates(Pi, Fs, Param#param{database = UDb}). + +prove_predicates(Pi, [F | Fs], Param = #param{next_goal = Next, choice = Cps, bindings = Bs, var_num = Vn}) -> + Cp = #cp{type = current_predicate, data = {Pi, Fs}, next = Next, bs = Bs, vn = Vn}, + erlog_ec_body:unify_prove_body(Pi, erlog_ec_support:pred_ind(F), Param#param{choice = [Cp | Cps]}); +prove_predicates(_Pi, [], Param) -> erlog_errors:fail(Param). + +%% prove_retract(Clause, Next, ChoicePoints, Bindings, VarNum, Database) -> +%% void. +%% Retract clauses in database matching Clause. +prove_retract({':-', H, B}, Params) -> + prove_retract(H, B, Params); +prove_retract(H, Params) -> + prove_retract(H, true, Params). + +prove_retractall({':-', H, B}, Params) -> + prove_retractall(H, B, Params); +prove_retractall(H, Params) -> + prove_retractall(H, true, Params). + +%% check_goal(Goal, Next, Bindings, Database, CutAfter, CutLabel) -> +%% {WellFormedBody,HasCut}. +%% Check to see that Goal is bound and ensure that it is well-formed. +check_goal(G0, Next, Bs, Db, Cut, Label) -> + case erlog_ec_support:dderef(G0, Bs) of + {_} -> erlog_errors:instantiation_error(Db); %Must have something to call + G1 -> + case catch {ok, well_form_goal(G1, Next, Cut, Label)} of + {erlog_error, E} -> erlog_errors:erlog_error(E, Db); + {ok, GC} -> GC %Body and cut + end + end. + +%% retract_clauses(Head, Body, Clauses, Next, ChoicePoints, Bindings, VarNum, Database) -> +%% void. +%% Try to retract Head and Body using Clauses which all have the same functor. +retract_clauses(_, _, [], Param) -> erlog_errors:fail(Param); +retract_clauses(Ch, Cb, [C], Param) -> retract_clauses(Ch, Cb, C, Param); +retract_clauses(Ch, Cb, C, Param = #param{next_goal = Next, choice = Cps, bindings = Bs0, var_num = Vn0, database = Db, cursor = Cursor}) -> %TODO foreach vs handmade recursion? + case erlog_ec_unify:unify_clause(Ch, Cb, C, Bs0, Vn0) of + {succeed, Bs1, Vn1} -> + %% We have found a right clause so now retract it. + {_, UDb} = erlog_memory:retract_clause(Db, erlog_ec_support:functor(Ch), element(1, C)), + Cp = #cp{type = retract, data = {Ch, Cb, {UDb, Cursor}}, next = Next, bs = Bs0, vn = Vn0}, + erlog_ec_core:prove_body(Param#param{goal = Next, choice = [Cp | Cps], bindings = Bs1, var_num = Vn1, database = UDb}); + fail -> + {{UCursor, Res}, UDb} = erlog_memory:next(Db, Cursor), + retract_clauses(Ch, Cb, Res, Param#param{cursor = UCursor, database = UDb}) + end. + +%% well_form_goal(Goal, Tail, HasCutAfter, CutLabel) -> {Body,HasCut}. +%% Check that Goal is well-formed, flatten conjunctions, fix cuts and +%% add explicit call to top-level variables. +well_form_goal({',', L, R}, Tail0, Cut0, Label) -> + {Tail1, Cut1} = well_form_goal(R, Tail0, Cut0, Label), + well_form_goal(L, Tail1, Cut1, Label); +well_form_goal({';', {'->', C0, T0}, E0}, Tail, Cut0, Label) -> + {T1, Tc} = well_form_goal(T0, Tail, Cut0, Label), + {C1, _} = well_form_goal(C0, [{{cut}, Label, true} | T1], true, Label), + {E1, Ec} = well_form_goal(E0, Tail, Cut0, Label), + {[{{if_then_else}, E1, Label} | C1], Tc or Ec}; +well_form_goal({';', L0, R0}, Tail, Cut0, Label) -> + {L1, Lc} = well_form_goal(L0, Tail, Cut0, Label), + {R1, Rc} = well_form_goal(R0, Tail, Cut0, Label), + {[{{disj}, R1} | L1], Lc or Rc}; +well_form_goal({'->', C0, T0}, Tail, Cut0, Label) -> + {T1, Cut1} = well_form_goal(T0, Tail, Cut0, Label), + %% N.B. an extra cut will be added at run-time! + {C1, _} = well_form_goal(C0, [{{cut}, Label, true} | T1], true, Label), + {[{{if_then}, Label} | C1], Cut1}; +well_form_goal({once, G}, Tail, Cut, Label) -> + {G1, _} = well_form_goal(G, [{{cut}, Label, true} | Tail], true, Label), + {[{{once}, Label} | G1], Cut}; +well_form_goal({V}, Tail, Cut, _Label) -> + {[{call, {V}} | Tail], Cut}; +well_form_goal(true, Tail, Cut, _Label) -> {Tail, Cut}; %No-op +well_form_goal(fail, _Tail, _Cut, _Label) -> {[fail], false}; %No further +well_form_goal('!', Tail, Cut, Label) -> + {[{{cut}, Label, not Cut} | Tail], true}; +well_form_goal(Goal, Tail, Cut, _Label) -> + erlog_ec_support:functor(Goal), %Check goal + {[Goal | Tail], Cut}. + +parse_int(Float) when is_float(Float) -> round(Float); +parse_int(String) when is_list(String) -> + case string:to_integer(String) of + {error, E} -> throw(E); + {Res, _} -> Res + end; +parse_int(Atom) when is_atom(Atom) -> + parse_int(atom_to_list(Atom)). + +to_string(Int) when is_integer(Int) -> integer_to_list(Int); +to_string(Value) -> lists:flatten(io_lib:format("~p", [Value])). + +%% initial_goal(Goal) -> {Goal,Bindings,NewVarNum}. +%% initial_goal(Goal, Bindings, VarNum) -> {Goal,NewBindings,NewVarNum}. +%% Check term for well-formedness as an Erlog term and replace '_' +%% variables with unique numbered variables. Error on non-well-formed +%% goals. +initial_goal(Goal) -> initial_goal(Goal, erlog_ec_support:new_bindings(), 0). + + +%% @private +initial_goal({'_'}, Bs, Vn) -> {{Vn}, Bs, Vn + 1}; %Anonymous variable +initial_goal({Name} = Var0, Bs, Vn) when is_atom(Name) -> + case erlog_ec_support:get_binding(Var0, Bs) of + {ok, Var1} -> {Var1, Bs, Vn}; + error -> + Var1 = {Vn}, + {Var1, erlog_ec_support:add_binding(Var0, Var1, Bs), Vn + 1} + end; +initial_goal([H0 | T0], Bs0, Vn0) -> + {H1, Bs1, Vn1} = initial_goal(H0, Bs0, Vn0), + {T1, Bs2, Vn2} = initial_goal(T0, Bs1, Vn1), + {[H1 | T1], Bs2, Vn2}; +initial_goal([], Bs, Vn) -> {[], Bs, Vn}; +initial_goal(S, Bs0, Vn0) when ?IS_FUNCTOR(S) -> + As0 = tl(tuple_to_list(S)), + {As1, Bs1, Vn1} = initial_goal(As0, Bs0, Vn0), + {list_to_tuple([element(1, S) | As1]), Bs1, Vn1}; +initial_goal(T, Bs, Vn) when ?IS_ATOMIC(T) -> {T, Bs, Vn}; +initial_goal(T, _Bs, _Vn) -> erlog_errors:type_error(callable, T). + +%% @private +%% partial_list(Term, Bindings) -> Term. +%% Dereference all variables and check if partial list. +partial_list([], _) -> []; +partial_list([H | T0], Bs) -> + T1 = partial_list(T0, Bs), + [H | T1]; +partial_list({V} = Var, Bs) -> + case ?BIND:find(V, Bs) of + {ok, T} -> partial_list(T, Bs); + error -> Var + end; +partial_list(Other, _) -> erlog_errors:type_error(list, Other). + +%% @private +prove_retract(H, B, Params = #param{database = Db}) -> + Functor = erlog_ec_support:functor(H), + {Res, Udb} = erlog_memory:get_procedure(Db, H), + case Res of + {cursor, Cursor, result, {clauses, Cs}} -> + erlog_ec_core:run_n_close(fun(Param) -> retract_clauses(H, B, Cs, Param) end, + Params#param{cursor = Cursor, database = Udb}); + {code, _} -> + erlog_errors:permission_error(modify, static_procedure, erlog_ec_support:pred_ind(Functor)); + built_in -> + erlog_errors:permission_error(modify, static_procedure, erlog_ec_support:pred_ind(Functor)); + undefined -> erlog_errors:fail(Params#param{database = Udb}) + end. + +%% @private +prove_retractall(H, B, Params = #param{database = Db}) -> + Functor = erlog_ec_support:functor(H), + {Res, Udb} = erlog_memory:get_procedure(Db, H), + case Res of + {cursor, Cursor, result, Result} -> + Fun = fun(Param) -> check_result(Result, H, B, Functor, Param) end, + erlog_ec_core:run_n_close(Fun, Params#param{cursor = Cursor, database = Udb}); + Result -> + check_result(Result, H, B, Functor, Params#param{database = Udb}) + end. + +retractall_clauses([], _, _, Params = #param{next_goal = Next}) -> erlog_ec_core:prove_body(Params#param{goal = Next}); +retractall_clauses(Clause, H, B, Params = #param{bindings = Bs0, var_num = Vn0, database = Db, cursor = Cursor}) -> + case erlog_ec_unify:unify_clause(H, B, Clause, Bs0, Vn0) of + {succeed, _, _} -> + {_, Udb1} = erlog_memory:retract_clause(Db, erlog_ec_support:functor(H), element(1, Clause)), + {{UCursor, Res}, UDb2} = erlog_memory:next(Udb1, Cursor), + retractall_clauses(Res, H, B, Params#param{cursor = UCursor, database = UDb2}); + fail -> retractall_clauses([], H, B, Params) + end. + +%% @private +check_result({built_in, _}, _, _, Functor, _) -> + erlog_errors:permission_error(modify, static_procedure, erlog_ec_support:pred_ind(Functor)); +check_result({code, _}, _, _, Functor, _) -> + erlog_errors:permission_error(modify, static_procedure, erlog_ec_support:pred_ind(Functor)); +check_result({clauses, Cs}, H, B, _, Params) -> + retractall_clauses(Cs, H, B, Params); +check_result(undefined, _, _, _, Params = #param{next_goal = Next}) -> + erlog_ec_core:prove_body(Params#param{goal = Next}); +check_result({erlog_error, E}, _, _, _, #param{database = Db}) -> erlog_errors:erlog_error(E, Db). \ No newline at end of file diff --git a/src/libs/standard/core/main/erlog_core.erl b/src/libs/standard/core/main/erlog_core.erl new file mode 100644 index 0000000..49c62c3 --- /dev/null +++ b/src/libs/standard/core/main/erlog_core.erl @@ -0,0 +1,208 @@ +%% Copyright (c) 2008-2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +-module(erlog_core). + +-include("erlog_core.hrl"). +-include("erlog_bips.hrl"). +-include("erlog_db.hrl"). +-include("erlog_dcg.hrl"). +-include("erlog_lists.hrl"). +-include("erlog_time.hrl"). + +-behaviour(erlog_stdlib). + +%% Main execution functions. +-export([prove_goal/1]). +%% Adding to database. +-export([load/1]). + +%% built_in_db(Db) -> Database. +%% Create an initial clause database containing the built-in +%% predicates and predefined library predicates. +load(DbState) -> + lists:foldl(fun(Head, UDBState) -> erlog_memory:load_kernel_space(UDBState, ?MODULE, Head) end, DbState, ?ERLOG_CORE). + +%% prove_goal(Goal, NextGoal, ChoicePoints, Bindings, VarNum, Database) -> +%% {succeed,ChoicePoints,NewBindings,NewVarNum,NewDatabase} | +%% {fail,NewDatabase}. +%% Prove one goal. We seldom return succeed here but usually go directly to +%% to NextGoal. +%% Handle built-in predicates here. RTFM for a description of the +%% built-ins. Hopefully we do the same. + +%% Logic and control. Conjunctions are handled in prove_body and true +%% has been compiled away. +prove_goal(Param = #param{goal = {call, G}, next_goal = Next0, choice = Cps, + bindings = Bs, var_num = Vn, database = Db}) -> + %% Only add cut CP to Cps if goal contains a cut. + Label = Vn, + case erlog_ec_logic:check_goal(G, Next0, Bs, Db, false, Label) of + {Next1, true} -> + %% Must increment Vn to avoid clashes!!! + Cut = #cut{label = Label}, + erlog_ec_core:prove_body(Param#param{goal = Next1, choice = [Cut | Cps], var_num = Vn + 1}); + {Next1, false} -> erlog_ec_core:prove_body(Param#param{goal = Next1, var_num = Vn + 1}) + end; +prove_goal(Params = #param{goal = fail}) -> erlog_errors:fail(Params); +prove_goal(Param = #param{goal = {'\\+', G}, next_goal = Next0, choice = Cps, bindings = Bs, var_num = Vn, database = Db}) -> + %% We effectively implementing \+ G with ( G -> fail ; true ). + Label = Vn, + {Next1, _} = erlog_ec_logic:check_goal(G, [{{cut}, Label, true}, fail], Bs, Db, true, Label), + Cp = #cp{type = if_then_else, label = Label, next = Next0, bs = Bs, vn = Vn}, + %%io:fwrite("PG(\\+): ~p\n", [{G1,[Cp|Cps]]), + %% Must increment Vn to avoid clashes!!! + erlog_ec_core:prove_body(Param#param{goal = Next1, choice = [Cp | Cps], var_num = Vn + 1}); +prove_goal(Param = #param{goal = repeat, next_goal = Next, choice = Cps, bindings = Bs, var_num = Vn}) -> + Cp = #cp{type = disjunction, next = [repeat | Next], bs = Bs, vn = Vn}, + erlog_ec_core:prove_body(Param#param{goal = Next, choice = [Cp | Cps]}); +%% Clause creation and destruction. +prove_goal(Param = #param{goal = {abolish, Pi0}, next_goal = Next, bindings = Bs, database = Db}) -> + case erlog_ec_support:dderef(Pi0, Bs) of + {'/', N, A} when is_atom(N), is_integer(A), A > 0 -> + {_, UDb} = erlog_memory:abolish_clauses(Db, {N, A}), + erlog_ec_core:prove_body(Param#param{goal = Next, database = UDb}); + Pi -> erlog_errors:type_error(predicate_indicator, Pi, Db) + end; +prove_goal(Param = #param{goal = {Assert, C0}, next_goal = Next, bindings = Bs, database = Db}) + when Assert == assert; Assert == assertz -> + C = erlog_ec_support:dderef(C0, Bs), + {_, UDb} = erlog_memory:assertz_clause(Db, C), + erlog_ec_core:prove_body(Param#param{goal = Next, database = UDb}); +prove_goal(Param = #param{goal = {asserta, C0}, next_goal = Next, bindings = Bs, database = Db}) -> + C = erlog_ec_support:dderef(C0, Bs), + {_, UDb} = erlog_memory:asserta_clause(Db, C), + erlog_ec_core:prove_body(Param#param{goal = Next, database = UDb}); +prove_goal(Param = #param{goal = {retract, C0}, bindings = Bs}) -> + C = erlog_ec_support:dderef(C0, Bs), + erlog_ec_logic:prove_retract(C, Param); +prove_goal(Param = #param{goal = {retractall, C0}, bindings = Bs}) -> + C = erlog_ec_support:dderef(C0, Bs), + erlog_ec_logic:prove_retractall(C, Param); +%% Clause retrieval and information +prove_goal(Param = #param{goal = {clause, H0, B}, bindings = Bs}) -> + H1 = erlog_ec_support:dderef(H0, Bs), + erlog_ec_logic:prove_clause(H1, B, Param); +prove_goal(Param = #param{goal = {current_predicate, Pi0}, bindings = Bs}) -> + Pi = erlog_ec_support:dderef(Pi0, Bs), + erlog_ec_logic:prove_current_predicate(Pi, Param); +prove_goal(Param = #param{goal = {predicate_property, H0, P}, bindings = Bs, database = Db}) -> + H = erlog_ec_support:dderef(H0, Bs), + {Res, UDb} = erlog_memory:get_procedure_type(Db, H), + case catch Res of + built_in -> erlog_ec_body:unify_prove_body(P, built_in, Param#param{database = UDb}); + compiled -> erlog_ec_body:unify_prove_body(P, compiled, Param#param{database = UDb}); + interpreted -> erlog_ec_body:unify_prove_body(P, interpreted, Param#param{database = UDb}); + undefined -> erlog_errors:fail(Param#param{database = UDb}); + {erlog_error, E} -> erlog_errors:erlog_error(E, UDb) + end; +%% External interface +prove_goal(Param = #param{goal = {ecall, C0, Val}, bindings = Bs, database = Db}) -> + %% Build the initial call. + %%io:fwrite("PG(ecall): ~p\n ~p\n ~p\n", [dderef(C0, Bs),Next,Cps]), + Efun = case erlog_ec_support:dderef(C0, Bs) of + {':', M, F} when is_atom(M), is_atom(F) -> + fun() -> M:F() end; + {':', M, {F, A}} when is_atom(M), is_atom(F) -> + fun() -> M:F(A) end; + {':', M, {F, A1, A2}} when is_atom(M), is_atom(F) -> + fun() -> M:F(A1, A2) end; + {':', M, T} when is_atom(M), ?IS_FUNCTOR(T) -> + L = tuple_to_list(T), + fun() -> apply(M, hd(L), tl(L)) end; + Fun when is_function(Fun) -> Fun; + Other -> erlog_errors:type_error(callable, Other, Db) + end, + erlog_ec_logic:prove_ecall(Efun, Val, Param); +%% Non-standard but useful. +prove_goal(Param = #param{goal = {writeln, _}, next_goal = Next, event_man = undefined}) -> + erlog_ec_core:prove_body(Param#param{goal = Next}); +prove_goal(Param = #param{goal = {writeln, T}, next_goal = Next, bindings = Bs, event_man = Evman}) -> + %% Display procedure. + Res = erlog_ec_support:write(T, Bs), + gen_event:notify(Evman, Res), + erlog_ec_core:prove_body(Param#param{goal = Next}); +%% File utils +prove_goal(Param = #param{goal = {consult, Name}, next_goal = Next, bindings = Bs, f_consulter = Consulter, database = Db}) -> + case erlog_file:consult(Consulter, erlog_ec_support:dderef(Name, Bs), Db) of + {ok, DbState} -> erlog_ec_core:prove_body(Param#param{goal = Next, database = DbState}); + {Err, Error} when Err == erlog_error; Err == error -> + erlog_errors:erlog_error(Error, Db) + end; +prove_goal(Param = #param{goal = {reconsult, Name}, next_goal = Next, f_consulter = Consulter, database = Db}) -> + case erlog_file:reconsult(Consulter, Name, Db) of + {ok, UdbState} -> erlog_ec_core:prove_body(Param#param{goal = Next, database = UdbState}); + {Err, Error} when Err == erlog_error; Err == error -> + erlog_errors:erlog_error(Error, Db) + end; +prove_goal(Param = #param{goal = {deconsult, Name}, next_goal = Next, f_consulter = Consulter, database = Db}) -> + case erlog_file:deconsult(Consulter, Name, Db) of + {ok, UDbState} -> erlog_ec_core:prove_body(Param#param{goal = Next, database = UDbState}); + {Err, Error} when Err == erlog_error; Err == error -> + erlog_errors:erlog_error(Error, Db) + end; +prove_goal(Param = #param{goal = {use, Library}, next_goal = Next, database = Db}) when is_atom(Library) -> + try Library:load(Db) of + Udb -> + erlog_ec_core:prove_body(Param#param{goal = Next, database = Udb}) + catch + _:_ -> erlog_errors:fail(Param) + end; +prove_goal(Param = #param{goal = {use, Library}, next_goal = Next, database = Db, f_consulter = Consulter, libs_dir = LD}) when is_list(Library) -> + case erlog_file:load_library(Consulter, lists:concat([LD, "/", Library]), Db) of + {ok, UDBState} -> erlog_ec_core:prove_body(Param#param{goal = Next, database = UDBState}); + _ -> erlog_errors:fail(Param) + end; +prove_goal(Param = #param{goal = {listing, Res}, next_goal = Next, bindings = Bs0, database = Db}) -> + {Content, Udb} = erlog_memory:listing(Db, []), + Bs = erlog_ec_support:add_binding(Res, Content, Bs0), + erlog_ec_core:prove_body(Param#param{goal = Next, bindings = Bs, database = Udb}); +prove_goal(Param = #param{goal = {listing, Pred, Res}, next_goal = Next, bindings = Bs0, database = Db}) -> + {Content, Udb} = erlog_memory:listing(Db, [Pred]), + Bs = erlog_ec_support:add_binding(Res, Content, Bs0), + erlog_ec_core:prove_body(Param#param{goal = Next, bindings = Bs, database = Udb}); +prove_goal(Param = #param{goal = {listing, Pred, Arity, Res}, next_goal = Next, bindings = Bs0, database = Db}) -> + {Content, Udb} = erlog_memory:listing(Db, [Pred, Arity]), + Bs = erlog_ec_support:add_binding(Res, Content, Bs0), + erlog_ec_core:prove_body(Param#param{goal = Next, bindings = Bs, database = Udb}); +prove_goal(Param = #param{goal = {findall, T, G, B}}) -> %findall start + erlog_ec_logic:prove_findall(T, G, B, Param); +prove_goal(Param = #param{goal = {findall, Tag, T0}, bindings = Bs, database = Db}) -> %findall finish + T1 = erlog_ec_support:dderef(T0, Bs), + UDb = erlog_memory:raw_append(Db, Tag, T1), %Append to saved list + erlog_errors:fail(Param#param{database = UDb}); +prove_goal(Param = #param{goal = {bagof, Goal, Fun, Res}, choice = Cs0, bindings = Bs0, next_goal = Next, var_num = Vn, database = Db}) -> + {Predicates, UDb} = erlog_memory:finadll(Db, Fun), + FunList = tuple_to_list(Fun), + ResultDict = erlog_ec_support:collect_alternatives(Goal, FunList, Predicates), + Collected = dict:fetch_keys(ResultDict), + [UBs | Choises] = lists:foldr( + fun(Key, Acc) -> + UpdBs0 = erlog_ec_support:update_result(Key, ResultDict, Res, Bs0), + UpdBs1 = erlog_ec_support:update_vars(Goal, FunList, Key, UpdBs0), + [#cp{type = disjunction, label = Fun, next = Next, bs = UpdBs1, vn = Vn} | Acc] + end, Cs0, Collected), + erlog_ec_core:prove_body(Param#param{goal = Next, bindings = UBs#cp.bs, choice = Choises, var_num = Vn + length(Choises), database = UDb}); +prove_goal(Param = #param{goal = {to_integer, NumV, Res}, next_goal = Next, bindings = Bs0}) -> + Num = erlog_ec_support:dderef(NumV, Bs0), + case catch (erlog_ec_logic:parse_int(Num)) of + Int when is_integer(Int) -> + Bs = erlog_ec_support:add_binding(Res, Int, Bs0), + erlog_ec_core:prove_body(Param#param{goal = Next, bindings = Bs}); + _ -> erlog_errors:fail(Param) + end; +prove_goal(Param = #param{goal = {to_string, VarV, Res}, next_goal = Next, bindings = Bs0}) -> + Var = erlog_ec_support:dderef(VarV, Bs0), + Bs = erlog_ec_support:add_binding(Res, erlog_ec_logic:to_string(Var), Bs0), + erlog_ec_core:prove_body(Param#param{goal = Next, bindings = Bs}). diff --git a/src/libs/standard/dcg/logic/erlog_ed_logic.erl b/src/libs/standard/dcg/logic/erlog_ed_logic.erl new file mode 100644 index 0000000..f4bcc3e --- /dev/null +++ b/src/libs/standard/dcg/logic/erlog_ed_logic.erl @@ -0,0 +1,108 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 12. Авг. 2014 17:48 +%%%------------------------------------------------------------------- +-module(erlog_ed_logic). +-author("tihon"). + +-include("erlog_core.hrl"). + +%% API +-export([expand_term/1, phrase/1]). + +%% expand_term(Term) -> {ExpTerm}. +%% expand_term(Term, VarNum) -> {ExpTerm,NewVarNum}. +%% Handle DCG expansion. We do NOT work backwards. +expand_term(Term) -> + {Exp, _} = expand_term(Term, 0), + Exp. + +expand_term({'-->', _, _} = Term, Vn) -> + dcg_rule(Term, Vn); +expand_term(Term, Vn) -> {Term, Vn}. + +phrase(Params = #param{goal = Goal, next_goal = Next0, bindings = Bs, var_num = Vn0}) -> + {phrase, GRBody, S0, S} = erlog_ec_support:dderef(Goal, Bs), + {Body, Vn1} = erlog_ed_logic:dcg_body(GRBody, S0, S, Vn0), + %% io:format("~p\n", [Body]), + Next1 = [{call, Body} | Next0], %Evaluate body + erlog_ec_core:prove_body(Params#param{goal = Next1, var_num = Vn1}). + +%% dcg_rule(Term, VarNum) -> {ExpTerm,NewVarNum}. +%% dcg_rule(DCGRule, VarIn, VarOout, VarNum) -> {ExpTerm,NewVarNum}. +%% dcg_non_term(NonTerminal, VarIn, VarOut) -> ExpTerm. +%% dcg_body(BodyTerm, VarIn, VarOut, VarNum) -> {ExpBody,NewVarOut,NewVarNum}. +%% dcg_goal(BodyGoal, VarIn, VarOut, VarNum) -> {ExpGaol,NewVarOut,NewVarNum}. +%% dcg_terminal(Terminals, VarIn, VarOut, VarNum) -> +%% {ExpTerms,NewVarOut,NewVarNum}. +%% dcg_body and dcg_goal do smae the thing except the dcg_body +%% guarantees the output variable is the one we specify. It may +%% insert an explicit '=' to get this. +dcg_rule(DCGRule, Vn0) -> + S0 = {Vn0}, + S = {Vn0 + 1}, + dcg_rule(DCGRule, S0, S, Vn0 + 2). + +dcg_rule({'-->', {',', H, RHC}, B}, S0, S, Vn0) -> + S1 = {Vn0}, + Head = dcg_non_term(H, S0, S), + {Goal1, S2, Vn1} = dcg_goal(B, S0, S1, Vn0 + 1), + {Goal2, Vn2} = dcg_terminals(RHC, S, S2, Vn1), + {{':-', Head, {',', Goal1, Goal2}}, Vn2}; +dcg_rule({'-->', H, B}, S0, S, Vn0) -> + Head = dcg_non_term(H, S0, S), + {Body, Vn1} = dcg_body(B, S0, S, Vn0), + {{':-', Head, Body}, Vn1}. + +dcg_non_term(A, S0, S) when is_atom(A) -> {A, S0, S}; +dcg_non_term(T, S0, S) when ?IS_FUNCTOR(T) -> + list_to_tuple(tuple_to_list(T) ++ [S0, S]); +dcg_non_term(Other, _, _) -> erlog_errors:type_error(callable, Other). + +dcg_body({',', G0, B0}, S0, S, Vn0) -> + S1 = {Vn0}, + {G1, S2, Vn1} = dcg_goal(G0, S0, S1, Vn0 + 1), + {B1, Vn2} = dcg_body(B0, S2, S, Vn1), + {{',', G1, B1}, Vn2}; +dcg_body(G0, S0, S, Vn0) -> + case dcg_goal(G0, S0, S, Vn0) of + {G1, S, Vn1} -> {G1, Vn1}; %Already uses S + {G1, S1, Vn1} -> %So we get S! + %% io:format("~p\n", [{G1,S0,S1,S}]), + {{',', G1, {'=', S1, S}}, Vn1} + end. + +dcg_goal('!', S0, _, Vn) -> {'!', S0, Vn}; +dcg_goal({_} = V, S0, S, Vn) -> + {{phrase, V, S0, S}, S, Vn}; +dcg_goal({'{}', G}, S0, _, Vn) -> {G, S0, Vn}; +dcg_goal({',', L0, R0}, S0, S, Vn0) -> + S1 = {Vn0}, + {L1, S2, Vn1} = dcg_goal(L0, S0, S1, Vn0 + 1), + {R1, S3, Vn2} = dcg_goal(R0, S2, S, Vn1), + {{',', L1, R1}, S3, Vn2}; +dcg_goal({';', L0, R0}, S0, S, Vn0) -> + {L1, Vn1} = dcg_body(L0, S0, S, Vn0), + {R1, Vn2} = dcg_body(R0, S0, S, Vn1), + {{';', L1, R1}, S, Vn2}; +dcg_goal({'->', GRIf, GRThen}, S0, S, Vn0) -> + S1 = {Vn0}, + {If, S2, Vn1} = dcg_goal(GRIf, S0, S1, Vn0 + 1), + {Then, S3, Vn2} = dcg_goal(GRThen, S2, S, Vn1), + {{'->', If, Then}, S3, Vn2}; +dcg_goal({'\\+', G0}, S0, S, Vn) -> + {G1, _, _} = dcg_goal(G0, S0, S, Vn), + {{'\\+', G1}, S0, Vn}; +dcg_goal(Lits, S0, S, Vn0) when is_list(Lits) -> + {ELits, Vn1} = dcg_terminals(Lits, S0, S, Vn0), + {ELits, S, Vn1}; +dcg_goal(NonT, S0, S, Vn) -> + Goal = dcg_non_term(NonT, S0, S), + {Goal, S, Vn}. + +dcg_terminals(Lits, S0, S, Vn) -> %Without 'C'/3 + {{'=', S0, Lits ++ S}, Vn}. \ No newline at end of file diff --git a/src/libs/standard/dcg/main/erlog_dcg.erl b/src/libs/standard/dcg/main/erlog_dcg.erl new file mode 100644 index 0000000..7982402 --- /dev/null +++ b/src/libs/standard/dcg/main/erlog_dcg.erl @@ -0,0 +1,39 @@ +%% Copyright (c) 2008-2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : erlog_dcg.erl +%% Author : Robert Virding +%% Purpose : DCG conversion and procedures. + +-module(erlog_dcg). + +-include("erlog_core.hrl"). +-include("erlog_dcg.hrl"). + +-behaviour(erlog_stdlib). + +-export([load/1]). +-export([prove_goal/1]). + +load(DbState) -> + lists:foldl(fun(Head, UDBState) -> erlog_memory:load_kernel_space(UDBState, ?MODULE, Head) end, DbState, ?ERLOG_DCG). + +prove_goal(Params = #param{goal = {expand_term, _, _} = Goal, bindings = Bs, var_num = Vn0}) -> + {expand_term, DCGRule, A2} = erlog_ec_support:dderef(Goal, Bs), + {Exp, Vn1} = erlog_ed_logic:expand_term(DCGRule, Vn0), + erlog_ec_body:unify_prove_body(A2, Exp, Params#param{var_num = Vn1}); +prove_goal(Params = #param{goal = {phrase, A, B}}) -> + erlog_ed_logic:phrase(Params#param{goal = {phrase, A, B, []}}); +prove_goal(Params = #param{goal = {phrase, _, _, _}}) -> + erlog_ed_logic:phrase(Params). \ No newline at end of file diff --git a/src/libs/standard/erlog_stdlib.erl b/src/libs/standard/erlog_stdlib.erl new file mode 100644 index 0000000..34633d6 --- /dev/null +++ b/src/libs/standard/erlog_stdlib.erl @@ -0,0 +1,19 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc erlog standart library interface +%%% +%%% @end +%%% Created : 12. Авг. 2014 18:31 +%%%------------------------------------------------------------------- +-module(erlog_stdlib). +-author("tihon"). + +-include("erlog.hrl"). +-include("erlog_core.hrl"). + +%% load database to kernel space +-callback load(Db :: #db_state{}) -> #db_state{}. + +%% proves goal Goal +-callback prove_goal(Params :: #param{}) -> ok. %TODO what return value? \ No newline at end of file diff --git a/src/libs/standard/lists/logic/erlog_el_logic.erl b/src/libs/standard/lists/logic/erlog_el_logic.erl new file mode 100644 index 0000000..49f326e --- /dev/null +++ b/src/libs/standard/lists/logic/erlog_el_logic.erl @@ -0,0 +1,106 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 12. Авг. 2014 18:01 +%%%------------------------------------------------------------------- +-module(erlog_el_logic). +-author("tihon"). + +-include("erlog_core.hrl"). + +%% API +-export([fail_append/5, + fail_insert/5, + fail_member/4, + memberchk/2, + insert/1, + reverse/2]). + +insert(Params = #param{goal = {insert, A1, A2, A3}, next_goal = Next, bindings = Bs, choice = Cps, var_num = Vn}) -> + FailFun = fun(LCp, LCps, LDb) -> %TODO db not needed + erlog_el_logic:fail_insert(LCp, Params#param{choice = LCps, database = LDb}, A1, A2, A3) + end, + Cp = #cp{type = compiled, data = FailFun, next = Next, bs = Bs, vn = Vn}, + erlog_ec_body:unify_prove_body(A3, [A2 | A1], Params#param{choice = [Cp | Cps]}). + +fail_append(#cp{next = Next0, bs = Bs0, vn = Vn}, Params, A1, L, A3) -> + H = {Vn}, + T = {Vn + 1}, + L1 = {Vn + 2}, + Bs1 = erlog_ec_support:add_binding(A1, [H | T], Bs0), %A1 always a variable here. + Next1 = [{append, T, L, L1} | Next0], + erlog_ec_body:unify_prove_body(A3, [H | L1], Params#param{next_goal = Next1, bindings = Bs1, + var_num = Vn + 3}). + +fail_insert(#cp{next = Next0, bs = Bs, vn = Vn}, Params, A1, X, A3) -> + H = {Vn}, + L = {Vn + 1}, + L1 = {Vn + 2}, + Next1 = [{insert, L, X, L1} | Next0], + erlog_ec_body:unify_prove_body(A1, [H | L], A3, [H | L1], Params#param{next_goal = Next1, bindings = Bs, var_num = Vn + 3}). + +fail_member(#cp{next = Next0, bs = Bs, vn = Vn}, Params, A1, A2) -> + H = {Vn}, + T = {Vn + 1}, + Next1 = [{member, A1, T} | Next0], + erlog_ec_body:unify_prove_body(A2, [H | T], Params#param{next_goal = Next1, bindings = Bs, var_num = Vn + 2}). + +%% memberchk_2(Head, NextGoal, Choicepoints, Bindings, VarNum, Database) -> void. +%% memberchk(X, [X|_]) :- !. +%% memberchk(X, [_|T]) :- member(X, T). +%% We don't build the list and we never backtrack so we can be smart +%% and match directly. Should we give a type error? +memberchk({memberchk, A1, A2}, Params = #param{next_goal = Next, bindings = Bs0}) -> + case erlog_ec_support:deref(A2, Bs0) of + [H | T] -> + case erlog_ec_unify:unify(A1, H, Bs0) of + {succeed, Bs1} -> + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}); + fail -> + memberchk({memberchk, A1, T}, Params) + end; + {_} -> erlog_errors:instantiation_error(); + _ -> erlog_errors:fail(Params) + end. + +%% reverse_2(Head, NextGoal, Choicepoints, Bindings, VarNum, Database) -> void. +%% reverse([], []). +%% reverse([H|L1], L) :- reverse(L1, L2), append(L2, [H], L). +%% Here we attempt to compile indexing in the first argument. +reverse({reverse, A1, A2}, Params = #param{next_goal = Next0, bindings = Bs0, choice = Cps, var_num = Vn}) -> + case erlog_ec_support:deref(A1, Bs0) of + [] -> + erlog_ec_body:unify_prove_body(A2, [], Params); + [H | T] -> + L = {Vn}, + L1 = A2, + %% Naive straight expansion of body. + %%Next1 = [{reverse,T,L},{append,L,[H],L1}|Next0], + %%prove_body(Next1, Cps, Bs0, Vn+1, Db); + %% Smarter direct calling of local function. + Next1 = [{append, L, [H], L1} | Next0], + reverse({reverse, T, L}, Params#param{next_goal = Next1, var_num = Vn + 1}); + {_} = Var -> + FailFun = fun(LCp, LCps, LDb) -> %TODO db not needed + fail_reverse(LCp, Params#param{choice = LCps, database = LDb}, Var, A2) + end, + Cp = #cp{type = compiled, data = FailFun, next = Next0, bs = Bs0, vn = Vn}, + Bs1 = erlog_ec_support:add_binding(Var, [], Bs0), + erlog_ec_body:unify_prove_body(A2, [], Params#param{choice = [Cp | Cps], bindings = Bs1}); + _ -> erlog_errors:fail(Params) %Will fail here! + end. + +%% @private +fail_reverse(#cp{next = Next, bs = Bs0, vn = Vn}, Params, A1, A2) -> + H = {Vn}, + T = {Vn + 1}, + L1 = A2, + L = {Vn + 2}, + Bs1 = erlog_ec_support:add_binding(A1, [H | T], Bs0), + %%Next1 = [{reverse,T,L},{apperse,L,[H],L1}|Next], + %%prove_body(Next1, Cps, Bs1, Vn+3, Db). + Next1 = [{append, L, [H], L1} | Next], + reverse({reverse, T, L}, Params#param{next_goal = Next1, bindings = Bs1, var_num = Vn + 3}). \ No newline at end of file diff --git a/src/libs/standard/lists/main/erlog_lists.erl b/src/libs/standard/lists/main/erlog_lists.erl new file mode 100644 index 0000000..506b221 --- /dev/null +++ b/src/libs/standard/lists/main/erlog_lists.erl @@ -0,0 +1,83 @@ +%% Copyright (c) 2013 Robert Virding +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. + +%% File : erlog_lists.erl +%% Author : Robert Virding +%% Purpose : Standard Erlog lists library. +%% +%% This is a standard lists library for Erlog. Everything here is +%% pretty basic and common to most Prologs. We are experimenting here +%% and some predicates are compiled. We only get a small benefit when +%% only implementing indexing on the first argument. + +-module(erlog_lists). + +-include("erlog_core.hrl"). +-include("erlog_lists.hrl"). + +-behaviour(erlog_stdlib). + +%% Main interface functions. +-export([load/1]). +-export([prove_goal/1]). + +load(DbState) -> + lists:foldl(fun(Head, UDBState) -> erlog_memory:load_kernel_space(UDBState, ?MODULE, Head) end, DbState, ?ERLOG_LISTS). + +prove_goal(Params = #param{goal = {length, ListVar, Len}, next_goal = Next, bindings = Bs0}) -> + case erlog_ec_support:dderef_list(ListVar, Bs0) of + List when is_list(List) -> + Bs1 = erlog_ec_support:add_binding(Len, length(List), Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}); + _ -> erlog_errors:fail(Params) + end; +prove_goal(Params = #param{goal = {append, A1, L, A3}, next_goal = Next0, bindings = Bs0, choice = Cps, var_num = Vn}) -> + case erlog_ec_support:deref(A1, Bs0) of + [] -> %Cannot backtrack + erlog_ec_body:unify_prove_body(L, A3, Params); + [H | T] -> %Cannot backtrack + L1 = {Vn}, + Next1 = [{append, T, L, L1} | Next0], + erlog_ec_body:unify_prove_body(A3, [H | L1], Params#param{next_goal = Next1, var_num = Vn + 1}); + {_} = Var -> %This can backtrack + FailFun = fun(LCp, LCps, LDb) -> %TODO db not needed + erlog_el_logic:fail_append(LCp, Params#param{choice = LCps, database = LDb}, Var, L, A3) + end, + Cp = #cp{type = compiled, data = FailFun, next = Next0, bs = Bs0, vn = Vn}, + Bs1 = erlog_ec_support:add_binding(Var, [], Bs0), + erlog_ec_body:unify_prove_body(L, A3, Params#param{choice = [Cp | Cps], bindings = Bs1}); + _ -> erlog_errors:fail(Params) %Will fail here! + end; +prove_goal(Params = #param{goal = {insert, _, _, _}}) -> + erlog_el_logic:insert(Params); +prove_goal(Params = #param{goal = {delete, A, B, C}}) -> + erlog_el_logic:insert(Params#param{goal = {insert, C, B, A}}); +prove_goal(Params = #param{goal = {member, A1, A2}, next_goal = Next, bindings = Bs, choice = Cps, var_num = Vn}) -> + FailFun = fun(LCp, LCps, LDb) -> + erlog_el_logic:fail_member(LCp, Params#param{choice = LCps, database = LDb}, A1, A2) + end, + Cp = #cp{type = compiled, data = FailFun, next = Next, bs = Bs, vn = Vn}, + T = {Vn}, + erlog_ec_body:unify_prove_body(A2, [A1 | T], Params#param{choice = [Cp | Cps], var_num = Vn + 1}); +prove_goal(Params = #param{goal = {memberchk, A1, A2}}) -> + erlog_el_logic:memberchk({memberchk, A1, A2}, Params); +prove_goal(Params = #param{goal = {sort, L0, S}, bindings = Bs}) -> + %% This may throw an erlog error, we don't catch it here. + L1 = lists:usort(erlog_ec_support:dderef_list(L0, Bs)), + erlog_ec_body:unify_prove_body(S, L1, Params); +%% reverse([], []). +%% reverse([H|L1], L) :- reverse(L1, L2), append(L2, [H], L). +%% Here we attempt to compile indexing in the first argument. +prove_goal(Params = #param{goal = {reverse, A1, A2}}) -> + erlog_el_logic:reverse({reverse, A1, A2}, Params). \ No newline at end of file diff --git a/src/libs/standard/math/erlog_math.erl b/src/libs/standard/math/erlog_math.erl new file mode 100644 index 0000000..86efb08 --- /dev/null +++ b/src/libs/standard/math/erlog_math.erl @@ -0,0 +1,35 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 15. Дек. 2014 21:12 +%%%------------------------------------------------------------------- +-module(erlog_math). +-author("tihon"). + +-behaviour(erlog_stdlib). + +-include("erlog_math.hrl"). +-include("erlog_core.hrl"). + +%% API +-export([load/1, prove_goal/1]). + +load(DbState) -> + lists:foldl(fun(Proc, UDBState) -> erlog_memory:load_kernel_space(UDBState, ?MODULE, Proc) end, DbState, ?ERLOG_MATH). + +prove_goal(Params = #param{goal = {round, _, _, _} = G, next_goal = Next, bindings = Bs0}) -> + {round, Number, Accuracy, Result} = erlog_ec_support:dderef(G, Bs0), + Rounded = round_float(Number, Accuracy), + case erlog_ec_support:try_add(Rounded, Result, Bs0) of + error -> erlog_errors:fail(Params); + Bs -> erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}) + end. + + +%% @private +round_float(N, _) when is_integer(N) -> N; +round_float(N, 0) -> round(N); +round_float(F, Accuracy) -> P = math:pow(10, Accuracy), round(F * P) / P. \ No newline at end of file diff --git a/src/libs/standard/parallel/erlog_parallel.erl b/src/libs/standard/parallel/erlog_parallel.erl new file mode 100644 index 0000000..7702cfa --- /dev/null +++ b/src/libs/standard/parallel/erlog_parallel.erl @@ -0,0 +1,84 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2015, +%%% @doc +%%% +%%% @end +%%% Created : 30. Янв. 2015 20:06 +%%%------------------------------------------------------------------- +-module(erlog_parallel). +-author("tihon"). + +-behaviour(erlog_stdlib). + +-include("erlog_core.hrl"). +-include("erlog_parallel.hrl"). + +%% API +-export([load/1, prove_goal/1]). + +load(DbState) -> + lists:foldl(fun(Proc, UDBState) -> + erlog_memory:load_kernel_space(UDBState, ?MODULE, Proc) end, DbState, ?ERLOG_PARALLEL). + +prove_goal(Params = #param{goal = {spawn, _, _} = G, next_goal = Next, bindings = Bs0}) -> + {spawn, Goal, Res} = erlog_ec_support:dderef(G, Bs0), + Parent = self(), + Pid = spawn( + fun() -> + R = (catch erlog_ec_core:prove_goal(Params#param{goal = Goal, next_goal = []})), + reply(Parent, R, erlog_ec_support:get_vars(Goal, Bs0)), + Parent ! {self(), finish} + end), + Bs1 = erlog_ec_support:add_binding(Res, Pid, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}); +prove_goal(Params = #param{goal = {join, _, _} = G, next_goal = Next, bindings = Bs0}) -> + {join, Pid, Timeout} = erlog_ec_support:dderef(G, Bs0), + case catch join(Pid, Timeout) of + ok -> erlog_ec_core:prove_body(Params#param{goal = Next}); + _ -> erlog_errors:fail(Params) + end; +prove_goal(Params = #param{goal = {check, _, _} = G, next_goal = Next, bindings = Bs0}) -> + {check, Pid, Result} = erlog_ec_support:dderef(G, Bs0), + case recv_res(Pid, 0) of + error -> erlog_errors:fail(Params); + empty -> Bs1 = erlog_ec_support:add_binding(Result, false, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}); + VarsGot -> + UBs = lists:foldl(fun({Var, Value}, UpdBs) -> erlog_ec_support:add_binding(Var, Value, UpdBs) end, Bs0, VarsGot), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = UBs}) + end. + + +%% @private +join_proc(Pid, TM) -> + receive + {Pid, finish} -> ok + after TM -> throw(timeout) + end. + +%% @private +recv_res(Pid, TM) -> + receive + {Pid, Result} when Result /= finish -> Result + after TM -> empty + end. + +%% @private +join(Pids, Timeout) when is_list(Pids) -> + lists:foreach(fun(Pid) -> join_proc(Pid, Timeout) end, Pids); +join(Pid, Timeout) -> join([Pid], Timeout). + +%% @private +reply(Parent, {succeed, _, Bs1, _, _}, StartVars) -> Parent ! {self(), extract_vars(StartVars, Bs1)}; +reply(Parent, _, _) -> Parent ! {self(), error}. + +%% @private +extract_vars(VarList, Bs) -> + lists:foldl( + fun({Var}, Acc) -> + case dict:find(Var, Bs) of + {ok, Value} -> [{{Var}, Value} | Acc]; + error -> Acc + end + end, [], VarList). \ No newline at end of file diff --git a/src/libs/standard/string/erlog_string.erl b/src/libs/standard/string/erlog_string.erl new file mode 100644 index 0000000..80b3e4b --- /dev/null +++ b/src/libs/standard/string/erlog_string.erl @@ -0,0 +1,127 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 22. Окт. 2014 20:54 +%%%------------------------------------------------------------------- +-module(erlog_string). +-author("tihon"). + +-include("erlog_string.hrl"). +-include("erlog_core.hrl"). + +-behaviour(erlog_stdlib). + +%% API +-export([load/1, prove_goal/1]). + + +load(DbState) -> + lists:foldl(fun(Head, UDBState) -> + erlog_memory:load_kernel_space(UDBState, ?MODULE, Head) end, DbState, ?ERLOG_STRING). + +prove_goal(Params = #param{goal = {concat, Strings, Res}, next_goal = Next, bindings = Bs0}) -> + case erlog_ec_support:dderef_list(Strings, Bs0) of + List when is_list(List) -> + ConcatMe = lists:foldr(fun preprocess_concat/2, [], List), + Bs1 = erlog_ec_support:add_binding(Res, lists:concat(ConcatMe), Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}); + _ -> erlog_errors:fail(Params) + end; +prove_goal(Params = #param{goal = {substring, _, _, _, _} = Goal, next_goal = Next, bindings = Bs0}) -> + {substring, From, To, Str, Res} = erlog_ec_support:dderef(Goal, Bs0), + Sublist = lists:sublist(Str, From, To - From + 1), + case erlog_ec_support:try_add(Sublist, Res, Bs0) of + error -> erlog_errors:fail(Params); + Bs -> erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}) + end; +prove_goal(Params = #param{goal = {indexof, _, _, _} = Goal, next_goal = Next, bindings = Bs0}) -> + {indexof, Str1, Str2, Res} = erlog_ec_support:dderef(Goal, Bs0), + case string:str(Str1, Str2) of + 0 -> erlog_errors:fail(Params); + Num -> + Bs1 = erlog_ec_support:add_binding(Res, Num, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}) + end; +prove_goal(Params = #param{goal = {split, _, _, _} = Goal, next_goal = Next, bindings = Bs0}) -> + case erlog_ec_support:dderef(Goal, Bs0) of + {split, Str, Del, Res} when is_list(Res) -> + List = string:tokens(Str, Del), + erlog_lists:prove_goal(Params#param{goal = {append, List, [], Res}}); + {split, Str, Del, Res} -> + List = string:tokens(Str, Del), + Bs1 = erlog_ec_support:add_binding(Res, List, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}) + end; +prove_goal(Params = #param{goal = {parse_int, _, _} = Goal, next_goal = Next, bindings = Bs0}) -> + {parse_int, Str, Int} = erlog_ec_support:dderef(Goal, Bs0), + case string:to_integer(Str) of + {error, _} -> + erlog_errors:fail(Params); + {Integer, _} -> + case erlog_ec_support:try_add(Integer, Int, Bs0) of + error -> erlog_errors:fail(Params); + Bs -> erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}) + end + end; +prove_goal(Params = #param{goal = {parse_float, _, _} = Goal, next_goal = Next, bindings = Bs0}) -> + {parse_float, Str, Res} = erlog_ec_support:dderef(Goal, Bs0), + case string:to_float(Str) of + {error, _} -> + erlog_errors:fail(Params); + {Float, _} -> + case erlog_ec_support:try_add(Float, Res, Bs0) of + error -> erlog_errors:fail(Params); + Bs -> erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}) + end + end; +prove_goal(Params = #param{goal = {str_number, _, _} = Goal, bindings = Bs0}) -> + {str_number, Str, Num} = erlog_ec_support:dderef(Goal, Bs0), + case erlog_ec_support:is_bound(Str) of + true -> + convert_string(Str, Num, Params); %string not bound, + false -> + convert_numeric(Str, Num, Params) + end. + + +%% @private +preprocess_concat(Object, Acc) when is_list(Object); is_tuple(Object) -> + case io_lib:printable_list(Object) of + true -> [Object | Acc]; + false -> [lists:flatten(io_lib:format("~p", [Object])) | Acc] + end; +preprocess_concat(Object, Acc) -> [Object | Acc]. + +%% @private +convert_string(Str, Num, Params) -> + case string:to_float(Str) of + {Float, _} -> + match_num(Float, Num, Params); + error -> + case string:to_integer(Str) of + {Integer, _} -> + match_num(Integer, Num, Params); + error -> + erlog_errors:fail(Params) + end + end. + +%% @private +convert_numeric(Str, Num, Params = #param{next_goal = Next, bindings = Bs0}) -> + case erlog_ec_support:is_bound(Num) of + true when is_number(Num) -> + S = lists:flatten(io_lib:format("~p", [Num])), + Bs1 = erlog_ec_support:add_binding(Str, S, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs1}); + false -> erlog_errors:fail(Params) + end. + +%% @private +match_num(Number, ResultVar, Params = #param{next_goal = Next, bindings = Bs0}) -> + case erlog_ec_support:try_add(Number, ResultVar, Bs0) of + error -> erlog_errors:fail(Params); + Bs -> erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}) + end. \ No newline at end of file diff --git a/src/libs/standard/time/logic/erlog_et_logic.erl b/src/libs/standard/time/logic/erlog_et_logic.erl new file mode 100644 index 0000000..3413b9e --- /dev/null +++ b/src/libs/standard/time/logic/erlog_et_logic.erl @@ -0,0 +1,60 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 12. Авг. 2014 18:10 +%%%------------------------------------------------------------------- +-module(erlog_et_logic). +-author("tihon"). + +-include("erlog_time.hrl"). + +%% API +-export([date_to_ts/1, date_string_to_data/1, data_to_ts/1, date_to_seconds/2, seconds_to_date/2, date_to_data/1, ts_to_date/1]). + +%% Time in microseconds, atom for output format +-spec seconds_to_date(Time :: integer(), atom()) -> integer(). +seconds_to_date(Time, day) -> Time / 86400; % day = 24 hours +seconds_to_date(Time, hour) -> Time / 3600; % hour = 60 min +seconds_to_date(Time, minute) -> Time / 60; % min = 60 sec +seconds_to_date(Time, sec) -> Time. + +%% Converts day|hour|minute to seconds +-spec date_to_seconds(integer(), atom()) -> integer(). +date_to_seconds(Time, day) -> Time * 86400; +date_to_seconds(Time, hour) -> Time * 3600; +date_to_seconds(Time, minute) -> Time * 60; +date_to_seconds(Time, sec) -> Time. + +%% Converts string date representation to timestamp. Format MM DD YYYY hh:mm:ss +-spec date_string_to_data(string()) -> tuple(). +date_string_to_data(DataStr) -> + [MStr, DStr, YStr, HStr, MnStr, SStr] = string:tokens(DataStr, " :"), + Month = erlog_ec_support:index_of(MStr, tuple_to_list(?MONTHS)), + {{list_to_integer(YStr), Month, list_to_integer(DStr)}, + {list_to_integer(HStr), list_to_integer(MnStr), list_to_integer(SStr)}}. + +%% Converts data tuple to timestamp +-spec data_to_ts(tuple()) -> integer(). +data_to_ts(Data) -> + calendar:datetime_to_gregorian_seconds(Data) - 62167219200. + +%% Converts data tuple to date tuple {{YYYY,MM,DD},{hh,mm,ss}} +-spec date_to_data(tuple()) -> tuple(). +date_to_data(Ts) -> + calendar:now_to_universal_time(Ts). + +%% Converts data tuple (part of timestamp: MegaSecs, Secs) to integer seconds +-spec date_to_ts(tuple()) -> integer(). +date_to_ts({M1, S1}) -> + TimeStr = lists:concat([M1, S1]), + list_to_integer(TimeStr). + +%% Converts timestamp to data tuple +-spec ts_to_date(integer()) -> tuple(). +ts_to_date(Timestamp) -> + TSStr = integer_to_list(Timestamp), + {M1, S1} = lists:split(4, TSStr), + {list_to_integer(M1), list_to_integer(S1), 0}. \ No newline at end of file diff --git a/src/libs/standard/time/main/erlog_time.erl b/src/libs/standard/time/main/erlog_time.erl new file mode 100644 index 0000000..e3250c2 --- /dev/null +++ b/src/libs/standard/time/main/erlog_time.erl @@ -0,0 +1,101 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 15. Июль 2014 0:27 +%%%------------------------------------------------------------------- +-module(erlog_time). +-author("tihon"). + +-behaviour(erlog_stdlib). + +-include("erlog_core.hrl"). +-include("erlog_time.hrl"). + +%% API +-export([load/1]). +-export([prove_goal/1]). + +load(DbState) -> + lists:foldl(fun(Head, UDBState) -> erlog_memory:load_kernel_space(UDBState, ?MODULE, Head) end, DbState, ?ERLOG_TIME). + +%% Returns current timestamp. +prove_goal(Params = #param{goal = {localtime, Var}, next_goal = Next, bindings = Bs0}) -> + {M, S, _} = os:timestamp(), + Now = erlog_et_logic:date_to_ts({M, S}), + Value = to_integer(erlog_ec_support:deref(Var, Bs0)), %convert to integer, as it can be string, or binary. + case erlog_ec_support:try_add(Now, Value, Bs0) of + error -> erlog_errors:fail(Params); + Bs -> erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}) + end; +%% Returns timestamp for data, ignoring time +prove_goal(Params = #param{goal = {date, DateString, Res}, next_goal = Next, bindings = Bs0}) -> + {{Y, M, D}, _} = erlog_et_logic:date_string_to_data(erlog_ec_support:check_var(DateString, Bs0)), + DataTS = erlog_et_logic:data_to_ts({{Y, M, D}, {0, 0, 0}}), + Bs = erlog_ec_support:add_binding(Res, DataTS, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}); +%% Returns timestamp for data, ignoring time +prove_goal(Params = #param{goal = {date, D, M, Y, Res}, next_goal = Next, bindings = Bs0}) -> + DataTS = erlog_et_logic:data_to_ts({{erlog_ec_support:check_var(Y, Bs0), erlog_ec_support:check_var(M, Bs0), erlog_ec_support:check_var(D, Bs0)}, {0, 0, 0}}), + Bs = erlog_ec_support:add_binding(Res, DataTS, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}); +%% Returns timestamp for data, ignoring data. +prove_goal(Params = #param{goal = {time, TimeString, Res}, next_goal = Next, bindings = Bs0}) -> + {_, {H, M, S}} = erlog_et_logic:date_string_to_data(erlog_ec_support:check_var(TimeString, Bs0)), %cut YMD + TS = S * erlog_et_logic:date_to_seconds(M, minute) * erlog_et_logic:date_to_seconds(H, hour), + Bs = erlog_ec_support:add_binding(Res, TS, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}); +%% Returns timestamp for data, ignoring data. +prove_goal(Params = #param{goal = {time, H, M, S, Res}, next_goal = Next, bindings = Bs0}) -> + TS = erlog_ec_support:check_var(S, Bs0) + * erlog_et_logic:date_to_seconds(erlog_ec_support:check_var(M, Bs0), minute) + * erlog_et_logic:date_to_seconds(erlog_ec_support:check_var(H, Bs0), hour), + Bs = erlog_ec_support:add_binding(Res, TS, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}); +%% Calculates differense between two timestamps. Returns the result in specifyed format +prove_goal(Params = #param{goal = {date_diff, _, _, _, _} = Goal, next_goal = Next, bindings = Bs0}) -> + {date_diff, TS1, TS2, Format, Res} = erlog_ec_support:deref(Goal, Bs0), + case check_bound([TS1, TS2, Format]) of + ok -> + Diff = timer:now_diff(erlog_et_logic:ts_to_date(erlog_ec_support:check_var(TS1, Bs0)), erlog_et_logic:ts_to_date(erlog_ec_support:check_var(TS2, Bs0))) / 1000000, + Time = erlog_et_logic:seconds_to_date(Diff, erlog_ec_support:check_var(Format, Bs0)), + case erlog_ec_support:try_add(Time, Res, Bs0) of + error -> erlog_errors:fail(Params); + Bs -> erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}) + end; + no -> erlog_errors:fail(Params) + end; +%% Adds number of seconds T2 in Type format to Time1. Returns timestamp +prove_goal(Params = #param{goal = {add_time, Time1, Type, T2, Res}, next_goal = Next, bindings = Bs0}) -> + Diff = erlog_ec_support:check_var(Time1, Bs0) + erlog_et_logic:date_to_seconds(erlog_ec_support:check_var(T2, Bs0), erlog_ec_support:check_var(Type, Bs0)), + Bs = erlog_ec_support:add_binding(Res, Diff, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}); +%% Converts timestamp to human readable format +prove_goal(Params = #param{goal = {date_print, TS1, Res}, next_goal = Next, bindings = Bs0}) -> + {{Year, Month, Day}, {Hour, Minute, Second}} = erlog_et_logic:date_to_data(erlog_et_logic:ts_to_date(erlog_ec_support:check_var(TS1, Bs0))), + DateStr = lists:flatten(io_lib:format("~s ~2w ~4w ~2w:~2..0w:~2..0w", [?MONTH(Month), Day, Year, Hour, Minute, Second])), + Bs = erlog_ec_support:add_binding(Res, DateStr, Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}); +%% Parses date string and returns timestamp. +prove_goal(Params = #param{goal = {date_parse, DataStr, Res}, next_goal = Next, bindings = Bs0}) -> + Data = erlog_et_logic:date_string_to_data(erlog_ec_support:check_var(DataStr, Bs0)), + Bs = erlog_ec_support:add_binding(Res, erlog_et_logic:data_to_ts(Data), Bs0), + erlog_ec_core:prove_body(Params#param{goal = Next, bindings = Bs}). + +%% @private +to_integer(V) when is_binary(V) -> binary_to_integer(V); +to_integer(V) when is_list(V) -> list_to_integer(V); +to_integer(V) -> V. + +%% @private +-spec check_bound(VarList :: list()) -> ok | no. +check_bound(VarList) -> + catch lists:foreach( + fun(Var) -> + case erlog_ec_support:is_bound(Var) of + true -> ok; + false -> throw(no) + end + end, VarList). \ No newline at end of file diff --git a/src/main/erlog_app.erl b/src/main/erlog_app.erl new file mode 100644 index 0000000..b64f67b --- /dev/null +++ b/src/main/erlog_app.erl @@ -0,0 +1,16 @@ +-module(erlog_app). + +-behaviour(application). + +%% Application callbacks +-export([start/2, stop/1]). + +%% =================================================================== +%% Application callbacks +%% =================================================================== + +start(_StartType, _StartArgs) -> + erlog_super_sup:start_link(). + +stop(_State) -> + ok. diff --git a/src/main/erlog_super_sup.erl b/src/main/erlog_super_sup.erl new file mode 100644 index 0000000..b9fb38c --- /dev/null +++ b/src/main/erlog_super_sup.erl @@ -0,0 +1,28 @@ +-module(erlog_super_sup). + +-behaviour(supervisor). + +%% API +-export([start_link/0]). + +%% Supervisor callbacks +-export([init/1]). + +%% Helper macro for declaring children of supervisor +-define(CHILD(I, Type), {I, {I, start_link, []}, permanent, 5000, Type, [I]}). + +%% =================================================================== +%% API functions +%% =================================================================== + +start_link() -> + supervisor:start_link({local, ?MODULE}, ?MODULE, []). + +%% =================================================================== +%% Supervisor callbacks +%% =================================================================== + +init([]) -> + ShellSup = ?CHILD(erlog_shell_sup, supervisor), + {ok, {{one_for_one, 5, 10}, [ShellSup]}}. + diff --git a/src/storage/erlog_dict.erl b/src/storage/erlog_dict.erl new file mode 100644 index 0000000..c505761 --- /dev/null +++ b/src/storage/erlog_dict.erl @@ -0,0 +1,246 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 18. июн 2014 18:00 +%%%------------------------------------------------------------------- + +-module(erlog_dict). + +-include("erlog_core.hrl"). + +-behaviour(erlog_storage). + +%% erlog callbacks +-export([new/1, + assertz_clause/2, + asserta_clause/2, + retract_clause/2, + abolish_clauses/2, + get_procedure/2, + get_procedure_type/2, + get_interp_functors/1, + findall/2, + listing/2, + close/2, + next/2]). + +%% erlog db callbacks +-export([db_assertz_clause/2, + db_asserta_clause/2, + db_retract_clause/2, + db_abolish_clauses/2, + db_findall/2, + get_db_procedure/2, + db_listing/2, + db_next/2]). + +new(_) -> {ok, dict:new()}. + +db_assertz_clause({StdLib, ExLib, Db}, {Collection, Head, Body0}) -> + Dict = erlog_db_storage:get_db(dict, Collection), + {Res, Udict} = assertz_clause({StdLib, ExLib, Dict}, {Head, Body0}), + erlog_db_storage:update_db(Collection, Udict), + {Res, Db}. + +assertz_clause({_, _, Db} = Memory, {Head, Body0}) -> + Udb = clause(Head, Body0, Memory, + fun(Functor, Cs, Body) -> + case check_duplicates(Cs, Head, Body) of + true -> Db; %found - do nothing + _ -> dict:append(Functor, {length(Cs), Head, Body}, Db) %not found - insert new + end + end), + {ok, Udb}. + +db_asserta_clause({StdLib, ExLib, Db}, {Collection, Head, Body0}) -> + Dict = erlog_db_storage:get_db(dict, Collection), + {Res, Udict} = asserta_clause({StdLib, ExLib, Dict}, {Head, Body0}), + erlog_db_storage:update_db(Collection, Udict), + {Res, Db}. + +asserta_clause({_, _, Db} = Memory, {Head, Body0}) -> + Udb = clause(Head, Body0, Memory, + fun(Functor, Cs, Body) -> + case check_duplicates(Cs, Head, Body) of + true -> Db; %found - do nothing + _ -> + dict:update(Functor, + fun(Old) -> + [{length(Cs), Head, Body} | Old] + end, [{length(Cs), Head, Body}], Db) %not found - insert new + end + end), + {ok, Udb}. + +db_retract_clause({StdLib, ExLib, Db}, {Collection, Functor, Ct}) -> + Dict = erlog_db_storage:get_db(dict, Collection), + {Res, Udict} = retract_clause({StdLib, ExLib, Dict}, {Functor, Ct}), + erlog_db_storage:update_db(Collection, Udict), + {Res, Db}. + +retract_clause({_, _, Db}, {Functor, Ct}) -> + Udb = case dict:is_key(Functor, Db) of + true -> + dict:update(Functor, fun(Old) -> lists:keydelete(Ct, 1, Old) end, [], Db); + false -> Db %Do nothing + end, + {ok, Udb}. + +db_abolish_clauses({StdLib, ExLib, Db}, {Collection, Functor}) -> + Dict = erlog_db_storage:get_db(dict, Collection), + {Res, Udict} = abolish_clauses({StdLib, ExLib, Dict}, Functor), + erlog_db_storage:update_db(Collection, Udict), + {Res, Db}. + +abolish_clauses({_, _, Db}, Functor) -> + Udb = case dict:is_key(Functor, Db) of + true -> dict:erase(Functor, Db); + false -> Db %Do nothing + end, + {ok, Udb}. + +db_findall({StdLib, ExLib, Db}, {Collection, Goal}) -> %for db_call + Functor = erlog_ec_support:functor(Goal), + Dict = erlog_db_storage:get_db(dict, Collection), + case dict:find(Functor, StdLib) of %search built-in first + {ok, StFun} -> {StFun, Db}; + error -> + case dict:find(Functor, ExLib) of %search libraryspace then + {ok, ExFun} -> {ExFun, Db}; + error -> + case dict:find(Functor, Dict) of %search userspace last + {ok, Cs} -> + Res = work_with_clauses(Cs), %TODO fix bagof, possibly broken by return format + {Res, Db}; + error -> {[], Db} + end + end + end. + +findall({StdLib, ExLib, Db}, Goal) -> %for bagof + Functor = erlog_ec_support:functor(Goal), + case dict:find(Functor, StdLib) of %search built-in first + {ok, StFun} -> {StFun, Db}; + error -> + case dict:find(Functor, ExLib) of %search libraryspace then + {ok, ExFun} -> {ExFun, Db}; + error -> + case dict:find(Functor, Db) of %search userspace last + {ok, Cs} -> {Cs, Db}; + error -> {[], Db} + end + end + end. + +close(Db, _) -> {ok, Db}. + +next(Db, undefined) -> {[], Db}; +next(Db, Queue) -> + case queue:out(Queue) of %take variant + {{value, Val}, UQ} -> + {{cursor, UQ, result, Val}, Db}; %return it + {empty, UQ} -> {{cursor, UQ, result, []}, Db} %nothing to return + end. + +db_next(Db, {Queue, _Table}) -> next(Db, Queue). + +get_db_procedure({StdLib, ExLib, Db}, {Collection, Goal}) -> + Dict = erlog_db_storage:get_db(dict, Collection), + {Res, Udict} = get_procedure({StdLib, ExLib, Dict}, Goal), + erlog_db_storage:update_db(Collection, Udict), + {Res, Db}. + +get_procedure({StdLib, ExLib, Db}, Goal) -> + Functor = erlog_ec_support:functor(Goal), + Res = case dict:find(Functor, StdLib) of %search built-in first + {ok, StFun} -> StFun; + error -> + case dict:find(Functor, ExLib) of %search libraryspace then + {ok, Cs} when is_list(Cs) -> + work_with_clauses(Cs); + {ok, ExFun} -> ExFun; + error -> + case dict:find(Functor, Db) of %search userspace last + {ok, Cs} -> + work_with_clauses(Cs); + error -> undefined + end + end + end, + {Res, Db}. + +get_procedure_type({StdLib, ExLib, Db}, Goal) -> + Functor = erlog_ec_support:functor(Goal), + Res = case dict:is_key(Functor, StdLib) of %search built-in first + true -> built_in; + false -> + case dict:is_key(Functor, ExLib) of %search libraryspace then + true -> compiled; + false -> + case dict:is_key(Functor, Db) of %search userspace last + true -> interpreted; + false -> undefined + end + end + end, + {Res, Db}. + +get_interp_functors({_, ExLib, Db}) -> + Library = dict:fetch_keys(ExLib), + UserSpace = dict:fetch_keys(Db), + {lists:concat([Library, UserSpace]), Db}. + +db_listing({StdLib, ExLib, Db}, {Collection, Params}) -> + Dict = erlog_db_storage:get_db(dict, Collection), + {Res, Udict} = listing({StdLib, ExLib, Dict}, Params), + erlog_db_storage:update_db(Collection, Udict), + {Res, Db}. + +listing({_, _, Db}, [Functor, Arity]) -> + {dict:fold( + fun({F, A} = Res, _, Acc) when F == Functor andalso A == Arity -> + [Res | Acc]; + (_, _, Acc) -> Acc + end, [], Db), Db}; +listing({_, _, Db}, [Functor]) -> + {dict:fold( + fun({F, Arity}, _, Acc) when F == Functor -> + [{Functor, Arity} | Acc]; + (_, _, Acc) -> Acc + end, [], Db), Db}; +listing({_, _, Db}, []) -> + {dict:fetch_keys(Db), Db}. + +%% @private +clause(Head, Body0, {_, _, Db}, ClauseFun) -> + {Functor, Body} = case catch {ok, erlog_ec_support:functor(Head), erlog_ec_body:well_form_body(Body0, false, sture)} of + {erlog_error, E} -> erlog_errors:erlog_error(E, Db); + {ok, F, B} -> {F, B} + end, + case dict:find(Functor, Db) of + {ok, Cs} -> ClauseFun(Functor, Cs, Body); + error -> dict:append(Functor, {0, Head, Body}, Db) + end. + +%% @private +%% true - duplicate found +-spec check_duplicates(list(), tuple(), tuple()) -> boolean(). +check_duplicates(Cs, Head, Body) -> + catch (lists:foldl( + fun({_, H, B}, _) when H == Head andalso B == Body -> throw(true); %find same fact + (_, Acc) -> Acc + end, false, Cs)). + +%% @private +form_clauses([]) -> {[], queue:new()}; +form_clauses([First | Loaded]) -> + Queue = queue:from_list(Loaded), + {First, Queue}. + +%% @private +work_with_clauses(Cs) -> + {First, Cursor} = form_clauses(Cs), + {cursor, Cursor, result, {clauses, First}}. \ No newline at end of file diff --git a/src/storage/erlog_ets.erl b/src/storage/erlog_ets.erl new file mode 100644 index 0000000..f0bc9e8 --- /dev/null +++ b/src/storage/erlog_ets.erl @@ -0,0 +1,241 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 18. июн 2014 18:00 +%%%------------------------------------------------------------------- + +-module(erlog_ets). + +-include("erlog_core.hrl"). + +-behaviour(erlog_storage). + +%% erlog callbacks +-export([new/1, + assertz_clause/2, + asserta_clause/2, + retract_clause/2, + abolish_clauses/2, + get_procedure/2, + get_procedure_type/2, + get_interp_functors/1, + findall/2, + listing/2, + close/2, + next/2]). + +%% erlog db callbacks +-export([db_assertz_clause/2, + db_asserta_clause/2, + db_retract_clause/2, + db_abolish_clauses/2, + db_findall/2, + get_db_procedure/2, + db_listing/2, + db_next/2]). + +new(_) -> {ok, ets:new(eets, [bag, private])}. + +db_assertz_clause({StdLib, ExLib, Db}, {Collection, Head, Body0}) -> + Ets = erlog_db_storage:get_db(ets, Collection), + {Res, _} = assertz_clause({StdLib, ExLib, Ets}, {Head, Body0}), + {Res, Db}. + +assertz_clause({_, _, Db} = Memory, {Head, Body0}) -> + clause(Head, Body0, Memory, + fun(Functor, Cs, Body) -> + case check_duplicates(Cs, Head, Body) of + false -> ok; %found - do nothing + _ -> ets:insert(Db, {Functor, {length(Cs), Head, Body}}) %not found - insert new + end + end), + {ok, Db}. + +db_asserta_clause({StdLib, ExLib, Db}, {Collection, Head, Body0}) -> + Ets = erlog_db_storage:get_db(ets, Collection), + {Res, _} = asserta_clause({StdLib, ExLib, Ets}, {Head, Body0}), + {Res, Db}. + +asserta_clause({_, _, Db} = Memory, {Head, Body0}) -> + clause(Head, Body0, Memory, + fun(Functor, Cs, Body) -> + case check_duplicates(Cs, Head, Body) of + false -> ok; %found - do nothing + _ -> + Clauses = [{Functor, {length(Cs), Head, Body}} | Cs], + ets:delete(Db, Functor), + ets:insert(Db, [Clauses]) + end + end), + {ok, Db}. + +db_retract_clause({StdLib, ExLib, Db}, {Collection, Functor, Ct}) -> + Ets = erlog_db_storage:get_db(ets, Collection), + {Res, _} = retract_clause({StdLib, ExLib, Ets}, {Functor, Ct}), + {Res, Db}. + +retract_clause({_, _, Db}, {Functor, Ct}) -> + case catch ets:lookup_element(Db, Functor, 2) of + Cs when is_list(Cs) -> + Object = lists:keyfind(Ct, 1, Cs), + ets:delete_object(Db, Object); + _ -> ok + end, + {ok, Db}. + +db_abolish_clauses({StdLib, ExLib, Db}, {Collection, Functor}) -> + Ets = erlog_db_storage:get_db(ets, Collection), + {Res, _} = abolish_clauses({StdLib, ExLib, Ets}, Functor), + {Res, Db}. + +abolish_clauses({_, _, Db}, Functor) -> + ets:delete(Db, Functor), + {ok, Db}. + +db_findall({StdLib, ExLib, Db}, {Collection, Goal}) -> %for db_call + Functor = erlog_ec_support:functor(Goal), + Ets = erlog_db_storage:get_db(ets, Collection), + case dict:find(Functor, StdLib) of %search built-in first + {ok, StFun} -> {StFun, Db}; + error -> + case dict:find(Functor, ExLib) of %search libraryspace then + {ok, ExFun} -> {ExFun, Db}; + error -> + CS = case catch ets:lookup_element(Ets, Functor, 2) of %search userspace last + Cs when is_list(Cs) -> Cs; + _ -> [] + end, + {work_with_clauses(CS), Db} + end + end. + +findall({StdLib, ExLib, Db}, Goal) -> + Functor = erlog_ec_support:functor(Goal), + case dict:find(Functor, StdLib) of %search built-in first + {ok, StFun} -> {StFun, Db}; + error -> + case dict:find(Functor, ExLib) of %search libraryspace then + {ok, ExFun} -> {ExFun, Db}; + error -> + CS = case catch ets:lookup_element(Db, Functor, 2) of %search userspace last + Cs when is_list(Cs) -> Cs; + _ -> [] + end, + {CS, Db} + end + end. + +close(Ets, undefined) -> {ok, Ets}; +close(Ets, Cursor) -> + put(Cursor, queue:new()), %save empty queue + {ok, Ets}. + +next(Ets, undefined) -> {[], Ets}; +next(Ets, Queue) -> + case queue:out(Queue) of %take variant + {{value, Val}, UQ} -> + {{cursor, UQ, result, Val}, Ets}; %return it + {empty, UQ} -> {{cursor, UQ, result, []}, Ets} %nothing to return + end. + +db_next(Db, {Queue, _Table}) -> next(Db, Queue). + +get_db_procedure({StdLib, ExLib, _}, {Collection, Goal}) -> + Ets = erlog_db_storage:get_db(ets, Collection), + get_procedure({StdLib, ExLib, Ets}, Goal). + +get_procedure({StdLib, ExLib, Db}, Goal) -> + Functor = erlog_ec_support:functor(Goal), + Res = case dict:find(Functor, StdLib) of %search built-in first + {ok, StFun} -> StFun; + error -> + case dict:find(Functor, ExLib) of %search libraryspace then + {ok, ExFun} -> ExFun; + error -> + case catch ets:lookup_element(Db, Functor, 2) of %search userspace last + Cs when is_list(Cs) -> work_with_clauses(Cs); + _ -> undefined + end + end + end, + {Res, Db}. + +get_procedure_type({StdLib, ExLib, Db}, Goal) -> + Functor = erlog_ec_support:functor(Goal), + Res = case dict:is_key(Functor, StdLib) of %search built-in first + true -> built_in; + false -> + case dict:is_key(Functor, ExLib) of %search libraryspace then + true -> compiled; + false -> + case ets:member(Db, Functor) of %search userspace last + true -> interpreted; + false -> undefined + end + end + end, + {Res, Db}. + +get_interp_functors({_, ExLib, Db}) -> + Library = dict:fetch_keys(ExLib), + + Res = ets:foldl(fun({Func, _}, Fs) -> [Func | Fs]; + (_, Fs) -> Fs + end, Library, Db), + {Res, Db}. + +db_listing({StdLib, ExLib, Db}, {Collection, Params}) -> + Ets = erlog_db_storage:get_db(ets, Collection), + {Res, _} = listing({StdLib, ExLib, Ets}, {Params}), + {Res, Db}. + +listing({_, _, Db}, {[Functor, Arity]}) -> + {ets:foldl( + fun({{F, A} = Res, _}, Acc) when F == Functor andalso A == Arity -> + [Res | Acc]; + (_, Acc) -> Acc + end, [], Db), Db}; +listing({_, _, Db}, {[Functor]}) -> + {ets:foldl( + fun({{F, Arity}, _}, Acc) when F == Functor -> + [{Functor, Arity} | Acc]; + (_, Acc) -> Acc + end, [], Db), Db}; +listing({_, _, Db}, {[]}) -> + {ets:foldl( + fun({Fun, _}, Acc) -> [Fun | Acc]; + (_, Acc) -> Acc + end, [], Db), Db}. + +%% @private +clause(Head, Body0, {_, _, Db}, ClauseFun) -> + {Functor, Body} = case catch {ok, erlog_ec_support:functor(Head), erlog_ec_body:well_form_body(Body0, false, sture)} of + {erlog_error, E} -> erlog_errors:erlog_error(E, Db); + {ok, F, B} -> {F, B} + end, + case ets:lookup(Db, Functor) of + [] -> ets:insert(Db, {Functor, {0, Head, Body}}); + Cs -> ClauseFun(Functor, Cs, Body) + end. + +%% @private +-spec check_duplicates(list(), tuple(), tuple()) -> boolean(). +check_duplicates(Cs, Head, Body) -> + lists:foldl( + fun({_, {_, H, B}}, _) when H == Head andalso B == Body -> false; %find same fact + (_, Acc) -> Acc + end, true, Cs). + +%% @private +form_clauses([]) -> {[], queue:new()}; +form_clauses([First | Loaded]) -> + Queue = queue:from_list(Loaded), + {First, Queue}. + +%% @private +work_with_clauses(Cs) -> + {First, Cursor} = form_clauses(Cs), + {cursor, Cursor, result, {clauses, First}}. \ No newline at end of file diff --git a/src/storage/erlog_memory.erl b/src/storage/erlog_memory.erl new file mode 100644 index 0000000..7ab4ff3 --- /dev/null +++ b/src/storage/erlog_memory.erl @@ -0,0 +1,216 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 18. июн 2014 21:48 +%%%------------------------------------------------------------------- +-module(erlog_memory). +-author("tihon"). + +-include("erlog.hrl"). +-include("erlog_core.hrl"). + +%% API +-export([ + load_native_library/2, + load_extended_library/2, + load_extended_library/3, + assertz_clause/3, + asserta_clause/3, + retract_clause/3, + abolish_clauses/2, + get_procedure/2, + get_procedure_type/2, + get_interp_functors/1, + assertz_clause/2, + asserta_clause/2, + finadll/2, + raw_store/3, + raw_fetch/2, + raw_append/3, + raw_erase/2, + listing/2, + next/2, + close/2]). + +-export([ + db_assertz_clause/3, + db_assertz_clause/4, + db_asserta_clause/4, + db_asserta_clause/3, + db_retract_clause/4, + db_abolish_clauses/3, + get_db_procedure/3, + db_findall/3, + db_listing/3, + db_next/3]). + +-export([load_kernel_space/3]). + + +%%%=================================================================== +%%% API +%%%=================================================================== +%% kernelspace predicate loading +load_kernel_space(DBState = #db_state{stdlib = StdLib}, Module, Functor) -> + UStdlib = dict:store(Functor, {built_in, Module}, StdLib), + DBState#db_state{stdlib = UStdlib}. + +%% libraryspace predicate loading +load_native_library(DBState = #db_state{stdlib = StdLib, exlib = ExLib}, {Functor, M, F}) -> + check_immutable(StdLib, Functor), + DBState#db_state{exlib = dict:store(Functor, {code, {M, F}}, ExLib)}. + +%% add prolog functor to libraryspace +load_extended_library(DBState, {':-', Head, Body}) -> load_extended_library(DBState, Head, Body); +load_extended_library(DBState, Head) -> load_extended_library(DBState, Head, true). +load_extended_library(DBState = #db_state{stdlib = StdLib, exlib = ExLib}, Head, Body) -> + check_immutable(StdLib, erlog_ec_support:functor(Head)), + {Res, UExLib} = erlog_dict:assertz_clause({StdLib, ExLib, ExLib}, {Head, Body}), %use erlog_dict module to assert library to exlib dict + {Res, DBState#db_state{exlib = UExLib}}. + +%% userspace predicate loading +assertz_clause(Database, {':-', Head, Body}) -> assertz_clause(Database, Head, Body); +assertz_clause(Database, Head) -> assertz_clause(Database, Head, true). +assertz_clause(DBState, Head, Body) -> + F = erlog_ec_support:functor(Head), + do_action(DBState, assertz_clause, F, {Head, Body}). + +asserta_clause(Database, {':-', H, B}) -> asserta_clause(Database, H, B); +asserta_clause(Database, H) -> asserta_clause(Database, H, true). +asserta_clause(DBState, Head, Body) -> + F = erlog_ec_support:functor(Head), + do_action(DBState, asserta_clause, F, {Head, Body}). + +db_assertz_clause(Database, Collection, {':-', Head, Body}) -> db_assertz_clause(Database, Collection, Head, Body); +db_assertz_clause(Database, Collection, Head) -> db_assertz_clause(Database, Collection, Head, true). +db_assertz_clause(DBState, Collection, Head, Body) -> + do_action(DBState, db_assertz_clause, {Collection, Head, Body}). + +db_asserta_clause(Database, Collection, {':-', H, B}) -> db_asserta_clause(Database, Collection, H, B); +db_asserta_clause(Database, Collection, H) -> db_asserta_clause(Database, Collection, H, true). +db_asserta_clause(DBState, Collection, Head, Body) -> + do_action(DBState, db_asserta_clause, {Collection, Head, Body}). + +next(DBState, Cursor) -> + do_next(DBState, next, Cursor). +db_next(DBState, Cursor, Table) -> + do_next(DBState, db_next, {Cursor, Table}). + +retract_clause(DBState, F, Ct) -> + do_action(DBState, retract_clause, F, {F, Ct}). + +db_retract_clause(DBState, Collection, F, Ct) -> + do_action(DBState, db_retract_clause, {Collection, F, Ct}). + +abolish_clauses(DBState = #db_state{stdlib = StdLib}, Func) -> + check_immutable(StdLib, Func), + check_abolish(abolish_clauses, Func, Func, DBState). + +db_abolish_clauses(DBState, Collection, Func) -> + check_abolish(db_abolish_clauses, Func, {Collection, Func}, DBState). + +get_procedure(DbState, Func) -> + do_action(DbState, get_procedure, Func). + +get_db_procedure(DbState, Collection, Func) -> + do_action(DbState, get_db_procedure, {Collection, Func}). + +get_procedure_type(DbState, Func) -> + do_action(DbState, get_procedure_type, Func). + +get_interp_functors(DbState) -> + do_action(DbState, get_interp_functors). + +db_findall(DbState, Collection, Fun) -> + do_action(DbState, db_findall, {Collection, Fun}). + +finadll(DbState, Fun) -> + do_action(DbState, findall, Fun). + +listing(DbState, Args) -> + do_action(DbState, listing, Args). + +db_listing(DbState, Collection, Args) -> + do_action(DbState, db_listing, {Collection, Args}). + +raw_store(DBState = #db_state{in_mem = InMem}, Key, Value) -> + Umem = store(Key, Value, InMem), + DBState#db_state{in_mem = Umem}. + +raw_fetch(#db_state{in_mem = InMem}, Key) -> + fetch(Key, InMem). + +raw_append(DBState = #db_state{in_mem = InMem}, Key, AppendValue) -> + Value = fetch(Key, InMem), + Umem = store(Key, lists:concat([Value, [AppendValue]]), InMem), + DBState#db_state{in_mem = Umem}. + +raw_erase(DBState = #db_state{in_mem = InMem}, Key) -> + Umem = dict:erase(Key, InMem), + DBState#db_state{in_mem = Umem}. + +close(DBState = #db_state{state = State, database = Db}, Cursor) -> + {Res, UState} = Db:close(State, Cursor), + {Res, DBState#db_state{state = UState}}. + + +%% @private +-spec do_action(#db_state{}, atom(), term(), term()) -> {any(), #db_state{}}. +do_action(DBState = #db_state{stdlib = StdLib, exlib = ExLib, database = Db, state = State}, Fun, F, Args) -> + check_immutable(StdLib, F), %modifying fact in default memory need to be checked + check_immutable(ExLib, F), + {Res, UState} = Db:Fun({StdLib, ExLib, State}, Args), + {Res, DBState#db_state{state = UState}}. + +%% @private +-spec do_action(#db_state{}, atom(), term()) -> {any(), #db_state{}}. +do_action(DBState = #db_state{stdlib = StdLib, exlib = ExLib, database = Db, state = State}, Fun, Args) -> + {Res, UState} = Db:Fun({StdLib, ExLib, State}, Args), + {Res, DBState#db_state{state = UState}}. + +%% @private +-spec do_action(#db_state{}, atom()) -> {any(), #db_state{}}. +do_action(DBState = #db_state{stdlib = StdLib, exlib = ExLib, database = Db, state = State}, Fun) -> + {Res, UState} = Db:Fun({StdLib, ExLib, State}), + {Res, DBState#db_state{state = UState}}. + +%% @private +do_next(DBState = #db_state{database = Db, state = State}, Fun, Cursor) -> + {Res, UState} = Db:Fun(State, Cursor), + Ans = case Res of + {cursor, After, result, Result} -> {After, Result}; %got new (or same cursor) and result. Form and return + [] -> {Cursor, []} %no result got - return old cursor and empty result + end, + {Ans, DBState#db_state{state = UState}}. + +%% @private +fetch(Key, Memory) -> + case dict:find(Key, Memory) of + error -> []; + {ok, Value} -> Value + end. + +%% @private +store(Key, Value, Memory) -> + dict:store(Key, Value, Memory). + +%% @private +check_abolish(F, Func, Params, State = #db_state{state = DbState, database = Db, stdlib = StdLib, exlib = ExLib}) -> + case dict:erase(Func, ExLib) of + ExLib -> %dict not changed - was not deleted. Search userspace + {Res, UState} = Db:F({StdLib, ExLib, DbState}, Params), + {Res, State#db_state{state = UState}}; + UExlib -> %dict changed -> was deleted + {ok, State#db_state{exlib = UExlib}} + end. + +%% @private +check_immutable(Dict, Functor) -> + case dict:is_key(Functor, Dict) of + false -> ok; + true -> + erlog_errors:permission_error(modify, static_procedure, erlog_ec_support:pred_ind(Functor)) %TODO will crash db process, but not erlog + end. \ No newline at end of file diff --git a/src/storage/erlog_storage.erl b/src/storage/erlog_storage.erl new file mode 100644 index 0000000..e28f339 --- /dev/null +++ b/src/storage/erlog_storage.erl @@ -0,0 +1,59 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 17. июн 2014 23:07 +%%%------------------------------------------------------------------- +-module(erlog_storage). +-author("tihon"). + +%% ------- Prolog ------- +%% add value right +-callback assertz_clause({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Param :: term()) -> {ok, NewState :: any()}. +%% same as assertz_clause, but work with specified database +-callback db_assertz_clause({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Param :: term()) -> {ok, NewState :: any()}. + +%% add value left +-callback asserta_clause({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Param :: term()) -> {ok, NewState :: any()}. +%% same as asserta_clause, but work with specified database +-callback db_asserta_clause({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Param :: term()) -> {ok, NewState :: any()}. + +%% find all values +-callback findall({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Functor :: tuple()) -> {Res :: list(), NewState :: any()}. +%% same as retract_clause, but work with specified database +-callback db_findall({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Functor :: tuple()) -> {Res :: list(), NewState :: any()}. + +%% get all values in memory by search criteria +-callback listing({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Param :: term()) -> {Res :: list(), NewState :: any()}. +%% same as retract_clause, but work with specified database +-callback db_listing({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Param :: term()) -> {Res :: list(), NewState :: any()}. + +%% remove selected functor +-callback retract_clause({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Param :: term()) -> {ok, NewState :: any()}. +%% same as retract_clause, but work with specified database +-callback db_retract_clause({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Param :: term()) -> {ok, NewState :: any()}. + +%% remove all matching functors +-callback abolish_clauses({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Func :: term()) -> {ok, NewState :: any()}. +%% same as abolish_clauses, but work with specified database +-callback db_abolish_clauses({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Func :: term()) -> {ok, NewState :: any()}. + +%% ------- System ------- +-callback new(Params :: list()) -> {ok, State :: any()}. + +%% close cursor +-callback close(State :: any(), Pid :: pid()) -> {ok, NewState :: any()}. + +%% get next result by cursor +-callback next(State :: any(), Pid :: any()) -> {[] | any(), NewState :: any()}. +-callback db_next(State :: any(), Params :: tuple()) -> {[] | any(), NewState :: any()}. + +-callback get_procedure({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Func :: term()) -> {atom, NewState :: any()} | {term(), NewState :: any()}. +%% same as get_procedure, but work with specified database +-callback get_db_procedure({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Func :: term()) -> {atom, NewState :: any()} | {term(), NewState :: any()}. + +-callback get_procedure_type({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}, Func :: term()) -> {atom(), NewState :: any()}. + +-callback get_interp_functors({Stdlib :: ets:tid(), ExLib :: ets:tid(), State :: any()}) -> {list(), NewState :: any()}. \ No newline at end of file diff --git a/test/erlog_test.erl b/test/erlog_test.erl new file mode 100644 index 0000000..88104f0 --- /dev/null +++ b/test/erlog_test.erl @@ -0,0 +1,38 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 07. Июль 2014 21:46 +%%%------------------------------------------------------------------- +-module(erlog_test). +-author("tihon"). + +-include_lib("eunit/include/eunit.hrl"). + +run_all_test() -> + Names = get_absolute_names(get_prolog_files()), + ?debugMsg(Names), + lists:foreach(fun run_one/1, Names). + +-spec run_one(File :: string()) -> ok. +run_one(File) -> + ?debugFmt("~nChecking file ~p~n", [File]), + {ok, ErlogWorker} = erlog:start_link([{event_h, {erlog_test_handler, []}}]), + ?debugMsg(File), + Res = erlog:execute(ErlogWorker, string:join(["consult(", File, ")."], "\"")), + ?debugMsg(Res), + ?assertEqual(true, Res), + Res1 = erlog:execute(ErlogWorker, "test_all."), + ?debugMsg(Res1), + ?assertEqual(true, Res1), + ok. + +get_absolute_names(FileNames) -> + lists:foldl(fun(Name, Acc) -> [filename:absname("test/prolog/" ++ Name) | Acc] end, [], FileNames). + +-spec get_prolog_files() -> list(). +get_prolog_files() -> + {ok, FileNames} = file:list_dir("test/prolog"), + FileNames. \ No newline at end of file diff --git a/test/erlog_test_handler.erl b/test/erlog_test_handler.erl new file mode 100644 index 0000000..e5fbdbb --- /dev/null +++ b/test/erlog_test_handler.erl @@ -0,0 +1,162 @@ +%%%------------------------------------------------------------------- +%%% @author tihon +%%% @copyright (C) 2014, +%%% @doc +%%% +%%% @end +%%% Created : 15. Июль 2014 12:55 +%%%------------------------------------------------------------------- +-module(erlog_test_handler). +-author("tihon"). + +-include_lib("eunit/include/eunit.hrl"). + +-behaviour(gen_event). + +%% API +-export([start_link/0, + add_handler/0]). + +%% gen_event callbacks +-export([init/1, + handle_event/2, + handle_call/2, + handle_info/2, + terminate/2, + code_change/3]). + +-define(SERVER, ?MODULE). + +-record(state, {}). + +%%%=================================================================== +%%% gen_event callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @doc +%% Creates an event manager +%% +%% @end +%%-------------------------------------------------------------------- +-spec(start_link() -> {ok, pid()} | {error, {already_started, pid()}}). +start_link() -> + gen_event:start_link({local, ?SERVER}). + +%%-------------------------------------------------------------------- +%% @doc +%% Adds an event handler +%% +%% @end +%%-------------------------------------------------------------------- +-spec(add_handler() -> ok | {'EXIT', Reason :: term()} | term()). +add_handler() -> + gen_event:add_handler(?SERVER, ?MODULE, []). + +%%%=================================================================== +%%% gen_event callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever a new event handler is added to an event manager, +%% this function is called to initialize the event handler. +%% +%% @end +%%-------------------------------------------------------------------- +-spec(init(InitArgs :: term()) -> + {ok, State :: #state{}} | + {ok, State :: #state{}, hibernate} | + {error, Reason :: term()}). +init([]) -> + {ok, #state{}}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever an event manager receives an event sent using +%% gen_event:notify/2 or gen_event:sync_notify/2, this function is +%% called for each installed event handler to handle the event. +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_event(Event :: term(), State :: #state{}) -> + {ok, NewState :: #state{}} | + {ok, NewState :: #state{}, hibernate} | + {swap_handler, Args1 :: term(), NewState :: #state{}, + Handler2 :: (atom() | {atom(), Id :: term()}), Args2 :: term()} | + remove_handler). +handle_event(Event, State) -> + ?debugFmt("~p~n", [Event]), + {ok, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever an event manager receives a request sent using +%% gen_event:call/3,4, this function is called for the specified +%% event handler to handle the request. +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_call(Request :: term(), State :: #state{}) -> + {ok, Reply :: term(), NewState :: #state{}} | + {ok, Reply :: term(), NewState :: #state{}, hibernate} | + {swap_handler, Reply :: term(), Args1 :: term(), NewState :: #state{}, + Handler2 :: (atom() | {atom(), Id :: term()}), Args2 :: term()} | + {remove_handler, Reply :: term()}). +handle_call(_Request, State) -> + Reply = ok, + {ok, Reply, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% This function is called for each installed event handler when +%% an event manager receives any other message than an event or a +%% synchronous request (or a system message). +%% +%% @end +%%-------------------------------------------------------------------- +-spec(handle_info(Info :: term(), State :: #state{}) -> + {ok, NewState :: #state{}} | + {ok, NewState :: #state{}, hibernate} | + {swap_handler, Args1 :: term(), NewState :: #state{}, + Handler2 :: (atom() | {atom(), Id :: term()}), Args2 :: term()} | + remove_handler). +handle_info(_Info, State) -> + {ok, State}. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever an event handler is deleted from an event manager, this +%% function is called. It should be the opposite of Module:init/1 and +%% do any necessary cleaning up. +%% +%% @spec terminate(Reason, State) -> void() +%% @end +%%-------------------------------------------------------------------- +-spec(terminate(Args :: (term() | {stop, Reason :: term()} | stop | +remove_handler | {error, {'EXIT', Reason :: term()}} | +{error, term()}), State :: term()) -> term()). +terminate(_Arg, _State) -> + ok. + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Convert process state when code is changed +%% +%% @end +%%-------------------------------------------------------------------- +-spec(code_change(OldVsn :: term() | {down, term()}, State :: #state{}, + Extra :: term()) -> + {ok, NewState :: #state{}}). +code_change(_OldVsn, State, _Extra) -> + {ok, State}. + +%%%=================================================================== +%%% Internal functions +%%%=================================================================== diff --git a/test/hanoy.pl b/test/hanoy.pl new file mode 100644 index 0000000..2af6d02 --- /dev/null +++ b/test/hanoy.pl @@ -0,0 +1,82 @@ +hanoy(1,A,B,_,[A-B]):-!. + +hanoy(N,A,B,C,L):- + + N1 is N-1, + + hanoy(N1,A,C,B,RL), + + hanoy(N1,C,B,A,RR), + + append(RL,[A-B|RR],L). + +subst(1,E,[_|R],[E|R]):-!. + +subst(N,E,[X|L],[X|L2]):-N1 is N-1, subst(N1,E,L,L2). + +moves([],_):-!. + +moves([A-B|T],L):- + + elem(A,L,[X|P1]), subst(A,P1,L,L2), + + elem(B,L,P2), subst(B,[X|P2],L2,L3), + +% writeln(L3), + + moves(T,L3). + + +moves1([],_):-!. + +moves1([A-B|T],L):- + + elem(A,L,[X|P1]), subst(A,P1,L,L2), + + elem(B,L,P2), subst(B,[X|P2],L2,L3), + + writeln(L3), + + moves1(T,L3). + + + + +elem(1,[X|_],X):-!. + +elem(N,[_|T],X) :- N1 is N-1, elem(N1,T,X). + +make2(0,S,S):-!. + +make2(N,T,S):- N1 is N-1, make2(N1,[N|T],S). + + + + +test_all:- + + N=10, + + hanoy(N,1,2,3,X), + + make2(N,[],Z), + + Res=[Z,[],[]], +% writeln(Res), + + moves(X,Res). + + +test_all1:- + + N=10, + + hanoy(N,1,2,3,X), + + make2(N,[],Z), + + Res=[Z,[],[]], + writeln(Res), + + moves1(X,Res). + diff --git a/test/prolog/t1.pl b/test/prolog/t1.pl new file mode 100644 index 0000000..1378fb3 --- /dev/null +++ b/test/prolog/t1.pl @@ -0,0 +1,39 @@ +% ���� +% ���������: run(S). +% ������ ������� ����� �� ������ ���������� ������ f. +% ���������: run1(�). +% ������ ������� ���������� ������ f. + +f("p1", 100). +f("p2", 200). +f("p3", 300). + +run(_):- + retract(result(_)), + false. +run(_):- + assert(result(0)), + false. +run(_):- + f(_, Amnt), + retract(result(S)), + Snew is S + Amnt, + assert(result(Snew)), + false. +run(S):- + result(S). + +run1(C):- + calc_count([], 0, C). +calc_count(L, C, Cc):- + f(Key, _Amnt), + \+(append(_, [Key|_], L)), + Cn is C + 1, + calc_count([Key|L], Cn, Cc). +calc_count(_, C, C). + +test_all:- + run(600), + run1(3). + +% :- test_all. diff --git a/test/prolog/t2.pl b/test/prolog/t2.pl new file mode 100644 index 0000000..7d22397 --- /dev/null +++ b/test/prolog/t2.pl @@ -0,0 +1,105 @@ +%%%%%%%%%%%%%% +%% there is +%% types.pl +%% https://drive.google.com/folderview?id=0B3uCF8tBzpM4bzBfaFBzNVFiRUk&usp=sharing +%%%%%%%%%%%%%% + +%�������� ����� + +%����� + +plus(A,B,C):- nonvar(A), nonvar(B), C is A+B. + +plus(A,B,C):- var(A),nonvar(B),A is C-B. + +plus(A,B,C):- var(B),nonvar(A),B is C-A. + +filter(a,X):-atom(X). + +filter(i,X):-integer(X). + +filter(at,X):-atomic(X). + +filter_list([],[],_). + +filter_list([X|T],[X|Tt],F) :- filter(F,X),!, filter_list(T,Tt,F). + +filter_list([_|T],Tt,F) :- filter_list(T,Tt,F). + +%������������ �������� + +fib(1,1). + +fib(2,1). + +fib(X,Y):- X>2, X1 is X-1, X2 is X-2, + + fib(X1,F1), + + fib(X2,F2), Y is F1+F2. + +range(X,Y,X):-X=2, X1 is X-1, X2 is X-2, + + fib(X1,F1), + + fib(X2,F2), Y is F1+F2. + +range(X,Y,X):-X= +%%% @doc +%%% +%%% @end +%%% Created : 08. Сент. 2014 23:51 +%%%------------------------------------------------------------------- +-module(speed_test). +-author("tihon"). + +-include_lib("eunit/include/eunit.hrl"). + +dict_test() -> + Worker = create_and_load(erlog_dict), + Before = os:timestamp(), + Res = erlog:execute(Worker, "test_all."), + ?debugMsg(Res), + ?assertEqual(true, Res), + After = os:timestamp(), + ?debugFmt("run dict_test for ~p seconds~n", [timer:now_diff(After, Before) / 1000000]). + +ets_test() -> + Worker = create_and_load(erlog_ets), + Before = os:timestamp(), + Res = erlog:execute(Worker, "test_all."), + ?debugMsg(Res), + ?assertEqual(true, Res), + After = os:timestamp(), + ?debugFmt("run ets_test for ~p seconds~n", [timer:now_diff(After, Before) / 1000000]). + +create_and_load(Module) -> + {ok, ErlogWorker} = erlog:start_link([{database, Module}]), + Res = erlog:execute(ErlogWorker, string:join(["consult(", filename:absname("test/" ++ "hanoy.pl"), ")."], "\"")), + ?debugMsg(Res), + ?assertEqual(true, Res), + ErlogWorker.