diff --git a/lib/src/metta/runner/stdlib.metta b/lib/src/metta/runner/stdlib.metta new file mode 100644 index 000000000..4e770b98b --- /dev/null +++ b/lib/src/metta/runner/stdlib.metta @@ -0,0 +1,200 @@ +;`$then`, `$else` should be of `Atom` type to avoid evaluation +; and infinite cycle in inference +(: if (-> Bool Atom Atom $t)) +(= (if True $then $else) $then) +(= (if False $then $else) $else) + +(: Error (-> Atom Atom ErrorType)) + +(: if-non-empty-expression (-> Atom Atom Atom Atom)) +(= (if-non-empty-expression $atom $then $else) + (chain (eval (get-metatype $atom)) $type + (eval (if-equal $type Expression + (eval (if-equal $atom () $else $then)) + $else )))) + +(: if-decons (-> Atom Variable Variable Atom Atom Atom)) +(= (if-decons $atom $head $tail $then $else) + (eval (if-non-empty-expression $atom + (chain (decons $atom) $list + (unify $list ($head $tail) $then $else) ) + $else ))) + +(: if-empty (-> Atom Atom Atom Atom)) +(= (if-empty $atom $then $else) + (eval (if-equal $atom Empty $then $else))) + +(: if-not-reducible (-> Atom Atom Atom Atom)) +(= (if-not-reducible $atom $then $else) + (eval (if-equal $atom NotReducible $then $else))) + +(: if-error (-> Atom Atom Atom Atom)) +(= (if-error $atom $then $else) + (eval (if-decons $atom $head $_ + (eval (if-equal $head Error $then $else)) + $else ))) + +(: return-on-error (-> Atom Atom Atom)) +(= (return-on-error $atom $then) + (eval (if-empty $atom Empty + (eval (if-error $atom $atom + $then ))))) + +(: switch (-> %Undefined% Expression Atom)) +(= (switch $atom $cases) + (chain (decons $cases) $list + (chain (eval (switch-internal $atom $list)) $res + (eval (if-not-reducible $res Empty $res)) ))) +(= (switch-internal $atom (($pattern $template) $tail)) + (unify $atom $pattern $template (eval (switch $atom $tail)))) + +; FIXME: subst and reduce are not used in interpreter implementation +; we could remove them + +(: subst (-> Atom Variable Atom Atom)) +(= (subst $atom $var $templ) + (unify $atom $var $templ + (Error (subst $atom $var $templ) + "subst expects a variable as a second argument") )) + +(: reduce (-> Atom Variable Atom Atom)) +(= (reduce $atom $var $templ) + (chain (eval $atom) $res + (eval (if-empty $res Empty + (eval (if-error $res $res + (eval (if-not-reducible $res + (eval (subst $atom $var $templ)) + (eval (reduce $res $var $templ)) )))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; MeTTa interpreter implementation ; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(= (match-types $type1 $type2 $then $else) + (eval (if-equal $type1 %Undefined% $then + (eval (if-equal $type2 %Undefined% $then + (eval (if-equal $type1 Atom $then + (eval (if-equal $type2 Atom $then + (unify $type1 $type2 $then $else) ))))))))) + +(= (type-cast $atom $type $space) + (chain (eval (get-type $atom $space)) $actual-type + (chain (eval (get-metatype $atom)) $meta + (eval (if-equal $type $meta $atom + (eval (match-types $actual-type $type $atom (Error $atom BadType))) ))))) + +(= (is-function $type) + (chain (eval (get-metatype $type)) $meta + (eval (switch ($type $meta) + ( + (($_ Expression) + (chain (eval (car $type)) $head + (unify $head -> True False) )) + ($_ False) ))))) + +(= (interpret $atom $type $space) + (chain (eval (get-metatype $atom)) $meta + (eval (if-equal $type Atom $atom + (eval (if-equal $type $meta $atom + (eval (switch ($type $meta) + ( + (($_type Variable) $atom) + (($_type Symbol) (eval (type-cast $atom $type $space))) + (($_type Grounded) (eval (type-cast $atom $type $space))) + (($_type Expression) (eval (interpret-expression $atom $type $space))) ))))))))) + +(= (interpret-expression $atom $type $space) + (eval (if-decons $atom $op $args + (chain (eval (get-type $op $space)) $op-type + (chain (eval (is-function $op-type)) $is-func + (unify $is-func True + (chain (eval (interpret-func $atom $op-type $type $space)) $reduced-atom + (eval (call $reduced-atom $type $space)) ) + (chain (eval (interpret-tuple $atom $space)) $reduced-atom + (eval (call $reduced-atom $type $space)) )))) + (eval (type-cast $atom $type $space)) ))) + +(= (interpret-func $expr $type $ret-type $space) + (eval (if-decons $expr $op $args + (chain (eval (interpret $op $type $space)) $reduced-op + (eval (return-on-error $reduced-op + (eval (if-decons $type $arrow $arg-types + (chain (eval (interpret-args $expr $args $arg-types $ret-type $space)) $reduced-args + (eval (return-on-error $reduced-args + (cons $reduced-op $reduced-args) ))) + (Error $type "Function type expected") ))))) + (Error $expr "Non-empty expression atom is expected") ))) + +(= (interpret-args $atom $args $arg-types $ret-type $space) + (unify $args () + (chain (eval (car $arg-types)) $actual-ret-type + (eval (match-types $actual-ret-type $ret-type () (Error $atom BadType)))) + (eval (if-decons $args $head $tail + (eval (if-decons $arg-types $head-type $tail-types + (chain (eval (interpret $head $head-type $space)) $reduced-head + ; check that head was changed otherwise Error or Empty in the head + ; can be just an argument which is passed by intention + (eval (if-equal $reduced-head $head + (eval (interpret-args-tail $atom $reduced-head $tail $tail-types $ret-type $space)) + (eval (return-on-error $reduced-head + (eval (interpret-args-tail $atom $reduced-head $tail $tail-types $ret-type $space)) ))))) + (Error $atom BadType) )) + (Error (interpret-atom $atom $args $arg-types $space) + "Non-empty expression atom is expected") )))) + +(= (interpret-args-tail $atom $head $args-tail $args-tail-types $ret-type $space) + (chain (eval (interpret-args $atom $args-tail $args-tail-types $ret-type $space)) $reduced-tail + (eval (return-on-error $reduced-tail + (cons $head $reduced-tail) )))) + +(= (interpret-tuple $atom $space) + (unify $atom () + $atom + (eval (if-decons $atom $head $tail + (chain (eval (interpret $head %Undefined% $space)) $rhead + (eval (if-empty $rhead Empty + (chain (eval (interpret-tuple $tail $space)) $rtail + (eval (if-empty $rtail Empty + (cons $rhead $rtail) )))))) + (Error (interpret-tuple $atom $space) "Non-empty expression atom is expected as an argument") )))) + +(= (call $atom $type $space) + (eval (if-error $atom $atom + (chain (eval $atom) $result + (eval (if-not-reducible $result $atom + (eval (if-empty $result Empty + (eval (if-error $result $result + (eval (interpret $result $type $space)) )))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Standard library written in MeTTa ; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(: match (-> Atom Atom Atom %Undefined%)) +(= (match $space $pattern $template) + (unify $pattern $space $template Empty)) + +(: let (-> Atom %Undefined% Atom Atom)) +(= (let $pattern $atom $template) + (unify $atom $pattern $template Empty)) + +(: let* (-> Expression Atom Atom)) +(= (let* $pairs $template) + (eval (if-decons $pairs ($pattern $atom) $tail + (let $pattern $atom (let* $tail $template)) + $template ))) + +(: case (-> %Undefined% Expression Atom)) +(= (case $atom $cases) (switch $atom $cases)) + +(: car (-> Expression Atom)) +(= (car $atom) + (eval (if-decons $atom $head $_ + $head + (Error (car $atom) "car expects a non-empty expression as an argument") ))) + +(: cdr (-> Expression Expression)) +(= (cdr $atom) + (eval (if-decons $atom $_ $tail + $tail + (Error (cdr $atom) "cdr expects a non-empty expression as an argument") ))) diff --git a/lib/src/metta/runner/stdlib2.rs b/lib/src/metta/runner/stdlib2.rs index 67200a91a..ce7f2d69b 100644 --- a/lib/src/metta/runner/stdlib2.rs +++ b/lib/src/metta/runner/stdlib2.rs @@ -398,210 +398,7 @@ pub fn register_rust_tokens(metta: &Metta) { metta.tokenizer().borrow_mut().move_front(&mut rust_tokens); } -pub static METTA_CODE: &'static str = " - -;`$then`, `$else` should be of `Atom` type to avoid evaluation -; and infinite cycle in inference -(: if (-> Bool Atom Atom $t)) -(= (if True $then $else) $then) -(= (if False $then $else) $else) - -(: Error (-> Atom Atom ErrorType)) - -(: if-non-empty-expression (-> Atom Atom Atom Atom)) -(= (if-non-empty-expression $atom $then $else) - (chain (eval (get-metatype $atom)) $type - (eval (if-equal $type Expression - (eval (if-equal $atom () $else $then)) - $else )))) - -(: if-decons (-> Atom Variable Variable Atom Atom Atom)) -(= (if-decons $atom $head $tail $then $else) - (eval (if-non-empty-expression $atom - (chain (decons $atom) $list - (unify $list ($head $tail) $then $else) ) - $else ))) - -(: if-empty (-> Atom Atom Atom Atom)) -(= (if-empty $atom $then $else) - (eval (if-equal $atom Empty $then $else))) - -(: if-not-reducible (-> Atom Atom Atom Atom)) -(= (if-not-reducible $atom $then $else) - (eval (if-equal $atom NotReducible $then $else))) - -(: if-error (-> Atom Atom Atom Atom)) -(= (if-error $atom $then $else) - (eval (if-decons $atom $head $_ - (eval (if-equal $head Error $then $else)) - $else ))) - -(: return-on-error (-> Atom Atom Atom)) -(= (return-on-error $atom $then) - (eval (if-empty $atom Empty - (eval (if-error $atom $atom - $then ))))) - -(: switch (-> %Undefined% Expression Atom)) -(= (switch $atom $cases) - (chain (decons $cases) $list - (chain (eval (switch-internal $atom $list)) $res - (eval (if-not-reducible $res Empty $res)) ))) -(= (switch-internal $atom (($pattern $template) $tail)) - (unify $atom $pattern $template (eval (switch $atom $tail)))) - -; FIXME: subst and reduce are not used in interpreter implementation -; we could remove them - -(: subst (-> Atom Variable Atom Atom)) -(= (subst $atom $var $templ) - (unify $atom $var $templ - (Error (subst $atom $var $templ) - \"subst expects a variable as a second argument\") )) - -(: reduce (-> Atom Variable Atom Atom)) -(= (reduce $atom $var $templ) - (chain (eval $atom) $res - (eval (if-empty $res Empty - (eval (if-error $res $res - (eval (if-not-reducible $res - (eval (subst $atom $var $templ)) - (eval (reduce $res $var $templ)) )))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; MeTTa interpreter implementation ; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(= (match-types $type1 $type2 $then $else) - (eval (if-equal $type1 %Undefined% $then - (eval (if-equal $type2 %Undefined% $then - (eval (if-equal $type1 Atom $then - (eval (if-equal $type2 Atom $then - (unify $type1 $type2 $then $else) ))))))))) - -(= (type-cast $atom $type $space) - (chain (eval (get-type $atom $space)) $actual-type - (chain (eval (get-metatype $atom)) $meta - (eval (if-equal $type $meta $atom - (eval (match-types $actual-type $type $atom (Error $atom BadType))) ))))) - -(= (is-function $type) - (chain (eval (get-metatype $type)) $meta - (eval (switch ($type $meta) - ( - (($_ Expression) - (chain (eval (car $type)) $head - (unify $head -> True False) )) - ($_ False) ))))) - -(= (interpret $atom $type $space) - (chain (eval (get-metatype $atom)) $meta - (eval (if-equal $type Atom $atom - (eval (if-equal $type $meta $atom - (eval (switch ($type $meta) - ( - (($_type Variable) $atom) - (($_type Symbol) (eval (type-cast $atom $type $space))) - (($_type Grounded) (eval (type-cast $atom $type $space))) - (($_type Expression) (eval (interpret-expression $atom $type $space))) ))))))))) - -(= (interpret-expression $atom $type $space) - (eval (if-decons $atom $op $args - (chain (eval (get-type $op $space)) $op-type - (chain (eval (is-function $op-type)) $is-func - (unify $is-func True - (chain (eval (interpret-func $atom $op-type $type $space)) $reduced-atom - (eval (call $reduced-atom $type $space)) ) - (chain (eval (interpret-tuple $atom $space)) $reduced-atom - (eval (call $reduced-atom $type $space)) )))) - (eval (type-cast $atom $type $space)) ))) - -(= (interpret-func $expr $type $ret-type $space) - (eval (if-decons $expr $op $args - (chain (eval (interpret $op $type $space)) $reduced-op - (eval (return-on-error $reduced-op - (eval (if-decons $type $arrow $arg-types - (chain (eval (interpret-args $expr $args $arg-types $ret-type $space)) $reduced-args - (eval (return-on-error $reduced-args - (cons $reduced-op $reduced-args) ))) - (Error $type \"Function type expected\") ))))) - (Error $expr \"Non-empty expression atom is expected\") ))) - -(= (interpret-args $atom $args $arg-types $ret-type $space) - (unify $args () - (chain (eval (car $arg-types)) $actual-ret-type - (eval (match-types $actual-ret-type $ret-type () (Error $atom BadType)))) - (eval (if-decons $args $head $tail - (eval (if-decons $arg-types $head-type $tail-types - (chain (eval (interpret $head $head-type $space)) $reduced-head - ; check that head was changed otherwise Error or Empty in the head - ; can be just an argument which is passed by intention - (eval (if-equal $reduced-head $head - (eval (interpret-args-tail $atom $reduced-head $tail $tail-types $ret-type $space)) - (eval (return-on-error $reduced-head - (eval (interpret-args-tail $atom $reduced-head $tail $tail-types $ret-type $space)) ))))) - (Error $atom BadType) )) - (Error (interpret-atom $atom $args $arg-types $space) - \"Non-empty expression atom is expected\") )))) - -(= (interpret-args-tail $atom $head $args-tail $args-tail-types $ret-type $space) - (chain (eval (interpret-args $atom $args-tail $args-tail-types $ret-type $space)) $reduced-tail - (eval (return-on-error $reduced-tail - (cons $head $reduced-tail) )))) - -(= (interpret-tuple $atom $space) - (unify $atom () - $atom - (eval (if-decons $atom $head $tail - (chain (eval (interpret $head %Undefined% $space)) $rhead - (eval (if-empty $rhead Empty - (chain (eval (interpret-tuple $tail $space)) $rtail - (eval (if-empty $rtail Empty - (cons $rhead $rtail) )))))) - (Error (interpret-tuple $atom $space) \"Non-empty expression atom is expected as an argument\") )))) - -(= (call $atom $type $space) - (eval (if-error $atom $atom - (chain (eval $atom) $result - (eval (if-not-reducible $result $atom - (eval (if-empty $result Empty - (eval (if-error $result $result - (eval (interpret $result $type $space)) )))))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; Standard library written in MeTTa ; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(: match (-> Atom Atom Atom %Undefined%)) -(= (match $space $pattern $template) - (unify $pattern $space $template Empty)) - -(: let (-> Atom %Undefined% Atom Atom)) -(= (let $pattern $atom $template) - (unify $atom $pattern $template Empty)) - -(: let* (-> Expression Atom Atom)) -(= (let* $pairs $template) - (eval (if-decons $pairs ($pattern $atom) $tail - (let $pattern $atom (let* $tail $template)) - $template ))) - -(: case (-> %Undefined% Expression Atom)) -(= (case $atom $cases) (switch $atom $cases)) - -(: car (-> Expression Atom)) -(= (car $atom) - (eval (if-decons $atom $head $_ - $head - (Error (car $atom) \"car expects a non-empty expression as an argument\") ))) - -(: cdr (-> Expression Expression)) -(= (cdr $atom) - (eval (if-decons $atom $_ $tail - $tail - (Error (cdr $atom) \"cdr expects a non-empty expression as an argument\") ))) - -"; +pub static METTA_CODE: &'static str = include_str!("stdlib.metta"); #[cfg(test)] mod tests {