extra/prolog/prolog.factor

   1 ! Copyright (C) 2007 Gavin Harrison
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: kernel sequences arrays vectors namespaces math strings
   5     combinators continuations quotations io assocs ;
   6
   7 IN: prolog
   8
   9 SYMBOL: pldb
  10 SYMBOL: plchoice
  11
  12 : init-pl ( -- ) V{ } clone pldb set V{ } clone plchoice set ;
  13
  14 : reset-choice ( -- ) V{ } clone plchoice set ;
  15 : remove-choice ( -- ) plchoice get pop drop ;
  16 : add-choice ( continuation -- )
  17     dup continuation? [ plchoice get push ] [ drop ] if ;
  18 : last-choice ( -- ) plchoice get pop continue ;
  19
  20 : rules ( -- vector ) pldb get ;
  21 : rule ( n -- rule ) dup rules length >= [ drop "No." ] [ rules nth ] if ;
  22
  23 : var? ( pl-obj -- ? )
  24     dup string? [ 0 swap nth LETTER? ] [ drop f ] if ;
  25 : const? ( pl-obj -- ? ) var? not ;
  26
  27 : check-arity ( pat fact -- pattern fact ? ) 2dup [ length ] 2apply = ;
  28 : check-elements ( pat fact -- ? ) [ over var? [ 2drop t ] [ = ] if ] 2all? ;
  29 : (double-bound) ( key value assoc -- ? )
  30     pick over at* [ pick = >r 3drop r> ] [ drop swapd set-at t ] if ;
  31 : single-bound? ( pat-d pat-f -- ? )
  32     H{ } clone [ (double-bound) ] curry 2all? ;
  33 : match-pattern ( pat fact -- ? )
  34     check-arity [ 2dup check-elements -rot single-bound? and ] [ 2drop f ] if ;
  35 : good-result? ( pat fact -- pat fact ? )
  36     2dup dup "No." = [ 2drop t ] [ match-pattern ] if ;
  37
  38 : add-rule ( name pat body -- ) 3array rules dup length swap set-nth ;
  39
  40 : (lookup-rule) ( name num -- pat-f rules )
  41     dup rule dup "No." = >r 0 swap nth swapd dupd = swapd r> or
  42     [ dup rule [ ] callcc0 add-choice ] when
  43     dup number? [ 1+ (lookup-rule) ] [ 2nip ] if ;
  44
  45 : add-bindings ( pat-d pat-f binds -- binds )
  46     clone
  47     [ over var? over const? or
  48         [ 2drop ] [ rot dup >r set-at r> ] if
  49     ] 2reduce ;
  50 : init-binds ( pat-d pat-f -- binds ) V{ } clone add-bindings >alist ;
  51
  52 : replace-if-bound ( binds elt -- binds elt' )
  53     over 2dup key? [ at ] [ drop ] if ;
  54 : deep-replace ( binds seq -- binds seq' )
  55     [ dup var? [ replace-if-bound ]
  56         [ dup array? [ dupd deep-replace nip ] when ] if
  57     ] map ;
  58
  59 : backtrace? ( result -- )
  60     dup "No." = [ remove-choice last-choice ]
  61     [ [ last-choice ] unless ] if ;
  62
  63 : resolve-rule ( pat-d pat-f rule-body -- binds )
  64     >r 2dup init-binds r> [ deep-replace >quotation call dup backtrace?
  65     dup t = [ drop ] when ] each ;
  66
  67 : rule>pattern ( rule -- pattern ) 1 swap nth ;
  68 : rule>body ( rule -- body ) 2 swap nth ;
  69
  70 : binds>fact ( pat-d pat-f binds -- fact )
  71     [ 2dup key? [ at ] [ drop ] if ] curry map good-result?
  72     [ nip ] [ last-choice ] if ;
  73
  74 : lookup-rule ( name pat -- fact )
  75     swap 0 (lookup-rule) dup "No." =
  76     [ nip ]
  77     [ dup rule>pattern swapd check-arity
  78         [ rot rule>body resolve-rule dup -roll binds>fact nip ] [ last-choice ] if
  79     ] if ;
  80
  81 : binding-resolve ( binds name pat -- binds )
  82     tuck lookup-rule dup backtrace? spin add-bindings ;
  83
  84 : is ( binds val var -- binds ) rot [ set-at ] keep ;