1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2 3% A Graph Reducer for T-Combinators: 4% Reduces a T-combinator expression to a final answer. Recognizes 5% the combinators I,K,S,B,C,S',B',C', cond, apply, arithmetic, tests, 6% basic list operations, and function definitions in the data base stored 7% as facts of the form t_def(_func, _args, _expr). 8% Written by Peter Van Roy 9 10% Uses write/1, compare/3, functor/3, arg/3. 11top :- 12 try(fac(3), _ans1), 13% write(_ans1), nl, 14 try(quick([3,1,2]), _ans2). 15% write(_ans2), nl. 16 17try(_inpexpr, _anslist) :- 18 listify(_inpexpr, _list), 19 curry(_list, _curry), 20 t_reduce(_curry, _ans), 21 make_list(_ans, _anslist). 22 23%% SWI-Prolog V7 compatibility hacks. 24 25end(X) :- atom(X), !. 26end(X) :- X == []. 27 28list_functor_name(Name) :- 29 functor([_|_], Name, _). 30 31%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 32 33% Examples of applicative functions which can be compiled & executed. 34% This test version compiles them just before each execution. 35 36% Factorial function: 37t_def(fac, [N], cond(N=0, 1, N*fac(N-1))). 38 39% Quicksort: 40t_def(quick, [_l], cond(_l=[], [], 41 cond(tl(_l)=[], _l, 42 quick2(split(hd(_l),tl(_l)))))). 43t_def(quick2, [_l], my_append(quick(hd(_l)), quick(tl(_l)))). 44 45t_def(split, [_e,_l], cond(_l=[], [[_e]|[]], 46 cond(hd(_l)=<_e, inserthead(hd(_l),split(_e,tl(_l))), 47 inserttail(hd(_l),split(_e,tl(_l)))))). 48t_def(inserthead, [_e,_l], [[_e|hd(_l)]|tl(_l)]). 49t_def(inserttail, [_e,_l], [hd(_l)|[_e|tl(_l)]]). 50 51t_def(my_append, [_a,_b], cond(_a=[], _b, [hd(_a)|my_append(tl(_a),_b)])). 52 53%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 54 55% Full reduction: 56% A dot '.' is printed for each reduction step. 57 58t_reduce(_expr, _ans) :- 59 atomic(_expr), !, 60 _ans=_expr. 61% The reduction of '$cons' must be here to avoid an infinite loop 62t_reduce([_y,_x|LF], [_yr,_xr|LF]) :- 63 list_functor_name(LF), 64 t_reduce(_x, _xr), 65 !, 66 t_reduce(_y, _yr), 67 !. 68t_reduce(_expr, _ans) :- 69 t_append(_next, _red, _form, _expr), 70% write('.'), 71 t_redex(_form, _red), 72 !, 73 t_reduce(_next, _ans), 74 !. 75 76t_append(_link, _link, _l, _l). 77t_append([_a|_l1], _link, _l2, [_a|_l3]) :- t_append(_l1, _link, _l2, _l3). 78 79% One step of the reduction: 80 81% Combinators: 82t_redex([_x,_g,_f,_k|sp], [[_xr|_g],[_xr|_f]|_k]) :- t_reduce(_x, _xr). 83t_redex([_x,_g,_f,_k|bp], [[_x|_g],_f|_k]). 84t_redex([_x,_g,_f,_k|cp], [_g,[_x|_f]|_k]). 85t_redex([_x,_g,_f|s], [[_xr|_g]|[_xr|_f]]) :- t_reduce(_x, _xr). 86t_redex([_x,_g,_f|b], [[_x|_g]|_f]). 87t_redex([_x,_g,_f|c], [_g,_x|_f]). 88t_redex([_y,_x|k], _x). 89t_redex([_x|i], _x). 90 91% Conditional: 92t_redex([_elsepart,_ifpart,_cond|cond], _ifpart) :- 93 t_reduce(_cond, _bool), _bool=true, !. 94 % Does NOT work if _bool is substituted in the call! 95t_redex([_elsepart,_ifpart,_cond|cond], _elsepart). 96 97% Apply: 98t_redex([_f|apply], _fr) :- 99 t_reduce(_f, _fr). 100 101% List operations: 102t_redex([_arg|hd], _x) :- 103 list_functor_name(LF), 104 t_reduce(_arg, [_y,_x|LF]). 105t_redex([_arg|tl], _y) :- 106 list_functor_name(LF), 107 t_reduce(_arg, [_y,_x|LF]). 108 109% Arithmetic: 110t_redex([_y,_x|_op], _res) :- 111 end(_op), 112 my_member(_op, ['+', '-', '*', '//', 'mod']), 113 t_reduce(_x, _xres), 114 t_reduce(_y, _yres), 115 number(_xres), number(_yres), 116 eval(_op, _res, _xres, _yres). 117 118% Tests: 119t_redex([_y,_x|_test], _res) :- 120 end(_test), 121 my_member(_test, [<, >, =<, >=, =\=, =:=]), 122 t_reduce(_x, _xres), 123 t_reduce(_y, _yres), 124 number(_xres), number(_yres), 125 (relop(_test, _xres, _yres) 126 -> _res=true 127 ; _res=false 128 ), !. 129 130% Equality: 131t_redex([_y,_x|=], _res) :- 132 t_reduce(_x, _xres), 133 t_reduce(_y, _yres), 134 (_xres=_yres -> _res=true; _res=false), !. 135 136% Arithmetic functions: 137t_redex([_x|_op], _res) :- 138 end(_op), 139 my_member(_op, ['-']), 140 t_reduce(_x, _xres), 141 number(_xres), 142 eval1(_op, _t, _xres). 143 144% Definitions: 145% Assumes a fact t_def(_func,_def) in the database for every 146% defined function. 147t_redex(_in, _out) :- 148 my_append(_par,_func,_in), 149 end(_func), 150 t_def(_func, _args, _expr), 151 t(_args, _expr, _def), 152 my_append(_par,_def,_out). 153 154% Basic arithmetic and relational operators: 155 156eval( +, C, A, B) :- C is A + B. 157eval( -, C, A, B) :- C is A - B. 158eval( *, C, A, B) :- C is A * B. 159eval( //, C, A, B) :- C is A // B. 160eval(mod, C, A, B) :- C is A mod B. 161 162eval1(-, C, A) :- C is -A. 163 164relop( <, A, B) :- A<B. 165relop( >, A, B) :- A>B. 166relop( =<, A, B) :- A=<B. 167relop( >=, A, B) :- A>=B. 168relop(=\=, A, B) :- A=\=B. 169relop(=:=, A, B) :- A=:=B. 170 171%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 172 173% Scheme T: 174% A Translation Scheme for T-Combinators 175 176% Translate an expression to combinator form 177% by abstracting out all variables in _argvars: 178t(_argvars, _expr, _trans) :- 179 listify(_expr, _list), 180 curry(_list, _curry), 181 t_argvars(_argvars, _curry, _trans), !. 182 183t_argvars([], _trans, _trans). 184t_argvars([_x|_argvars], _in, _trans) :- 185 t_argvars(_argvars, _in, _mid), 186 t_vars(_mid, _vars), % calculate variables in each subexpression 187 t_trans(_x, _mid, _vars, _trans). % main translation routine 188 189% Curry the original expression: 190% This converts an applicative expression of any number 191% of arguments and any depth of nesting into an expression 192% where all functions are curried, i.e. all function 193% applications are to one argument and have the form 194% [_arg|_func] where _func & _arg are also of that form. 195% Input is a nested function application in list form. 196% Currying makes t_trans faster. 197curry(_a, _a) :- (var(_a); atomic(_a)), !. 198curry([_func|_args], _cargs) :- 199 currylist(_args, _cargs, _func). 200 201% Transform [_a1, ..., _aN] to [_cN, ..., _c1|_link]-_link 202currylist([], _link, _link) :- !. 203currylist([_a|_args], _cargs, _link) :- 204 curry(_a, _c), 205 currylist(_args, _cargs, [_c|_link]). 206 207% Calculate variables in each subexpression: 208% To any expression a list of the form 209% [_vexpr, _astr, _fstr] is matched. 210% If the expression is a variable or an atom 211% then this list only has the first element. 212% _vexpr = List of all variables in the expression. 213% _astr, _fstr = Similar structures for argument & function. 214t_vars(_v, [[_v]]) :- var(_v), !. 215t_vars(_a, [[]]) :- atomic(_a), !. 216t_vars([_func], [[]]) :- atomic(_func), !. 217t_vars([_arg|_func], [_g,[_g1|_af1],[_g2|_af2]]) :- 218 t_vars(_arg, [_g1|_af1]), 219 t_vars(_func, [_g2|_af2]), 220 unionv(_g1, _g2, _g). 221 222% The main translation routine: 223% trans(_var, _curriedexpr, _varexpr, _result) 224% The translation scheme T in the article is followed literally. 225% A good example of Prolog as a specification language. 226t_trans(_x, _a, _, [_a|k]) :- (atomic(_a); var(_a), _a\==_x), !. 227t_trans(_x, _y, _, i) :- _x==_y, !. 228t_trans(_x, _e, [_ve|_], [_e|k]) :- notinv(_x, _ve). 229t_trans(_x, [_f|_e], [_vef,_sf,_se], _res) :- 230 _sf=[_vf|_], 231 _se=[_ve|_other], 232 (end(_e); _other=[_,[_ve1|_]], _ve1\==[]), 233 t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, _res). 234t_trans(_x, [_g|[_f|_e]], [_vefg,_sg,_sef], _res) :- 235 _sg=[_vg|_], 236 _sef=[_vef,_sf,_se], 237 _se=[_ve|_], 238 _sf=[_vf|_], 239 t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, _res). 240 241% First complex rule of translation scheme T: 242t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, _e) :- 243 notinv(_x, _ve), _x==_f, !. 244t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, [_resf,_e|b]) :- 245 notinv(_x, _ve), inv(_x, _vf), _x\==_f, !, 246 t_trans(_x, _f, _sf, _resf). 247t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, [_f,_rese|c]) :- 248 /* inv(_x, _ve), */ 249 notinv(_x, _vf), !, 250 t_trans(_x, _e, _se, _rese). 251t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, [_resf,_rese|s]) :- 252 /* inv(_x, _ve), inv(_x, _vf), */ 253 t_trans(_x, _e, _se, _rese), 254 t_trans(_x, _f, _sf, _resf). 255 256% Second complex rule of translation scheme T: 257t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_g,_e|c]) :- 258 _x==_f, notinv(_x, _vg), !. 259t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_resg,_e|s]) :- 260 _x==_f, /* inv(_x, _vg), */ !, 261 t_trans(_x, _g, _sg, _resg). 262t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_g,_resf,_e|cp]) :- 263 /* _x\==_f, */ inv(_x, _vf), notinv(_x, _vg), !, 264 t_trans(_x, _f, _sf, _resf). 265t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_resg,_resf,_e|sp]) :- 266 /* _x\==_f, */ inv(_x, _vf), /* inv(_x, _vg), */ !, 267 t_trans(_x, _f, _sf, _resf), 268 t_trans(_x, _g, _sg, _resg). 269t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_f|_e]) :- 270 /* notinv(_x, _vf), */ _x==_g, !. 271t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_resg,_f,_e|bp]) :- 272 /* notinv(_x, _vf), inv(_x, _vg), _x\==_g, */ 273 t_trans(_x, _g, _sg, _resg). 274 275%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 276 277% List utilities: 278 279% Convert curried list into a regular list: 280make_list(_a, _a) :- atomic(_a). 281make_list([_b,_a|LF], [_a|_rb]) :- 282 list_functor_name(LF), 283 make_list(_b, _rb). 284 285listify(_X, _X) :- 286 (var(_X); atomic(_X)), !. 287listify(_Expr, [_Op|_LArgs]) :- 288 functor(_Expr, _Op, N), 289 listify_list(1, N, _Expr, _LArgs). 290 291listify_list(I, N, _, []) :- I>N, !. 292listify_list(I, N, _Expr, [_LA|_LArgs]) :- I=<N, !, 293 arg(I, _Expr, _A), 294 listify(_A, _LA), 295 I1 is I+1, 296 listify_list(I1, N, _Expr, _LArgs). 297 298my_member(X, [X|_]). 299my_member(X, [_|L]) :- my_member(X, L). 300 301my_append([], L, L). 302my_append([X|L1], L2, [X|L3]) :- my_append(L1, L2, L3). 303 304%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 305 306% Set utilities: 307% Implementation inspired by R. O'Keefe, Practical Prolog. 308% Sets are represented as sorted lists without duplicates. 309% Predicates with 'v' suffix work with sets containing uninstantiated vars. 310 311% *** Intersection 312intersectv([], _, []). 313intersectv([A|S1], S2, S) :- intersectv_2(S2, A, S1, S). 314 315intersectv_2([], _, _, []). 316intersectv_2([B|S2], A, S1, S) :- 317 compare(Order, A, B), 318 intersectv_3(Order, A, S1, B, S2, S). 319 320intersectv_3(<, _, S1, B, S2, S) :- intersectv_2(S1, B, S2, S). 321intersectv_3(=, A, S1, _, S2, [A|S]) :- intersectv(S1, S2, S). 322intersectv_3(>, A, S1, _, S2, S) :- intersectv_2(S2, A, S1, S). 323 324intersectv_list([], []). 325intersectv_list([InS|Sets], OutS) :- intersectv_list(Sets, InS, OutS). 326 327intersectv_list([]) --> []. 328intersectv_list([S|Sets]) --> intersectv(S), intersectv_list(Sets). 329 330% *** Difference 331diffv([], _, []). 332diffv([A|S1], S2, S) :- diffv_2(S2, A, S1, S). 333 334diffv_2([], A, S1, [A|S1]). 335diffv_2([B|S2], A, S1, S) :- 336 compare(Order, A, B), 337 diffv_3(Order, A, S1, B, S2, S). 338 339diffv_3(<, A, S1, B, S2, [A|S]) :- diffv(S1, [B|S2], S). 340diffv_3(=, A, S1, _, S2, S) :- diffv(S1, S2, S). 341diffv_3(>, A, S1, _, S2, S) :- diffv_2(S2, A, S1, S). 342 343% *** Union 344unionv([], S2, S2). 345unionv([A|S1], S2, S) :- unionv_2(S2, A, S1, S). 346 347unionv_2([], A, S1, [A|S1]). 348unionv_2([B|S2], A, S1, S) :- 349 compare(Order, A, B), 350 unionv_3(Order, A, S1, B, S2, S). 351 352unionv_3(<, A, S1, B, S2, [A|S]) :- unionv_2(S1, B, S2, S). 353unionv_3(=, A, S1, _, S2, [A|S]) :- unionv(S1, S2, S). 354unionv_3(>, A, S1, B, S2, [B|S]) :- unionv_2(S2, A, S1, S). 355 356% *** Subset 357subsetv([], _). 358subsetv([A|S1], [B|S2]) :- 359 compare(Order, A, B), 360 subsetv_2(Order, A, S1, S2). 361 362subsetv_2(=, _, S1, S2) :- subsetv(S1, S2). 363subsetv_2(>, A, S1, S2) :- subsetv([A|S1], S2). 364 365% For unordered lists S1: 366small_subsetv([], _). 367small_subsetv([A|S1], S2) :- inv(A, S2), small_subsetv(S1, S2). 368 369% *** Membership 370inv(A, [B|S]) :- 371 compare(Order, A, B), 372 inv_2(Order, A, S). 373 374inv_2(=, _, _). 375inv_2(>, A, S) :- inv(A, S). 376 377% *** Non-membership 378notinv(A, S) :- notinv_2(S, A). 379 380notinv_2([], _). 381notinv_2([B|S], A) :- 382 compare(Order, A, B), 383 notinv_3(Order, A, S). 384 385notinv_3(<, _, _). 386notinv_3(>, A, S) :- notinv_2(S, A). 387 388%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 389