* eval.c (eval_init): Register new search function as intrinsic.

* lib.c (search_list): New static function.
(search): New function.

* lib.h (search): New function declared.

* txr.1: Documented.

* txr.vim: Regenerated.

6 files changed, 164 insertions, 32 deletions

diff --git a/ChangeLog b/ChangeLog
index 9cbb1bb3..d792a7d9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2014-06-06  Kaz Kylheku  <kaz@kylheku.com>
+
+	* eval.c (eval_init): Register new search function as intrinsic.
+
+	* lib.c (search_list): New static function.
+	(search): New function.
+
+	* lib.h (search): New function declared.
+
+	* txr.1: Documented.
+
+	* txr.vim: Regenerated.
+
 2014-06-05  Kaz Kylheku  <kaz@kylheku.com>
 
 	* parser.l: Adding an explicit lexical rule to
diff --git a/eval.c b/eval.c
index 1be989f2..a4f320ab 100644
--- a/eval.c
+++ b/eval.c
@@ -3528,6 +3528,7 @@ void eval_init(void)
   reg_fun(intern(lit("refset"), user_package), func_n3(refset));
   reg_fun(intern(lit("replace"), user_package), func_n4o(replace, 2));
   reg_fun(intern(lit("update"), user_package), func_n2(update));
+  reg_fun(intern(lit("search"), user_package), func_n4o(search, 2));
 
   reg_fun(intern(lit("symbol-value"), user_package), func_n1(symbol_value));
   reg_fun(intern(lit("symbol-function"), user_package), func_n1(symbol_function));
diff --git a/lib.c b/lib.c
index 5c51ed7f..a459f44f 100644
--- a/lib.c
+++ b/lib.c
@@ -5105,6 +5105,72 @@ val update(val seq, val fun)
   return seq;
 }
 
+static val search_list(val seq, val key, val testfun, val keyfun)
+{
+  val iter, siter, kiter;
+  val pos = zero;
+
+  switch (type(key)) {
+  case NIL:
+    return pos;
+  case CONS:
+  case LCONS:
+  case LIT:
+  case STR:
+  case LSTR:
+  case VEC:
+    /* TODO: optimize me */
+    for (iter = seq; iter; iter = cdr(iter)) {
+      for (siter = iter, kiter = key;
+           siter && kiter;
+           siter = cdr(siter), kiter = cdr(kiter))
+      {
+        if (!funcall2(testfun,
+                      funcall1(keyfun, car(siter)),
+                      funcall1(keyfun, car(kiter))))
+        {
+          pos = plus(pos, one);
+          break;
+        }
+      }
+
+      if (!kiter)
+        return pos;
+
+      if (!siter)
+        break;
+    }
+    break;
+  default:
+    type_mismatch(lit("search: ~s is not a sequence"), cons, nao);
+  }
+
+  return nil;
+}
+
+val search(val seq, val key, val testfun, val keyfun)
+{
+  testfun = default_arg(testfun, equal_f);
+  keyfun = default_arg(keyfun, identity_f);
+
+  switch (type(seq)) {
+  case NIL:
+    return if3(length(key) == zero, zero, nil);
+  case CONS:
+  case LCONS:
+  case LIT:
+  case STR:
+  case LSTR:
+  case VEC:
+    /* TODO: optimize me */
+    return search_list(seq, key, testfun, keyfun);
+  default:
+    type_mismatch(lit("search: ~s is not a sequence"), cons, nao);
+  }
+
+  return seq;
+}
+
 val env(void)
 {
   if (env_list) {
diff --git a/lib.h b/lib.h
index 3724b6f9..c67866c8 100644
--- a/lib.h
+++ b/lib.h
@@ -744,6 +744,7 @@ val ref(val seq, val ind);
 val refset(val seq, val ind, val newval);
 val replace(val seq, val items, val from, val to);
 val update(val seq, val fun);
+val search(val seq, val key, val from, val to);
 val env(void);
 val obj_print(val obj, val stream);
 val obj_pprint(val obj, val stream);
diff --git a/txr.1 b/txr.1
index 2a62737d..e34c5118 100644
--- a/txr.1
+++ b/txr.1
@@ -9918,6 +9918,57 @@ This operation is destructive: it may work "in place" by modifying
 the original sequence. The caller should retain the return value
 and stop relying on the original input sequence.
 
+.SS Function search
+
+.TP
+Syntax:
+
+  (search <haystack> <needle> [<testfun> [<keyfun>])
+
+.TP
+Description:
+
+The search function determines whether the sequence <needle> occurs as substring
+within <haystack>, under the given comparison function <testfun> and
+key function <keyfun>.  If this is the case, then the zero-based position of
+the leftmost occurrence of <key> within <haystack> is returned. Otherwise nil
+is returned to indicate that <key> does not occur within <haystack>.
+If <key> is empty, then zero is always returned.
+
+The arguments <haystack> and <needle> are sequences: lists, vectors
+or strings, in any combination.
+
+If <needle> is not empty, then occurs at some position N within <haystack> if
+the first element of <needle> matches the element at position N of <haystack>,
+the second element of <needle> matches the element at position N+1 of
+<haystack> and so forth, for all elements of <needle>. A match between elements
+is determined by passing each element through <keyfun>, and then comparing
+the resulting values using <testfun>.
+
+If <testfun> is supplied, it must be a function which can be
+called with two arguments. If it is not supplied, it defaults to eql.
+
+If <keyfun> is supplied, it must be a function which can be called
+with one argument. If it is not supplied, it deafaults to identity.
+
+.TP
+Examples:
+
+  ;; fails because 3.0 doesn't match 3 under the default eql function
+  [search #(1.0 3.0 4.0 7.0) '(3 4)] -> nil
+
+  ;; occurrence found at position 1: (3.0 4.0) matches (3 4) under =
+  [search #(1.0 3.0 4.0 7.0) '(3 4) =] -> 1
+
+  ;; "even odd odd odd even" pattern matches at position 2
+  [search #(1 1 2 3 5 7 8) '(2 1 1 1 2) : evenp] -> 2
+
+  ;; Case insensitive string search
+  [search "abcd" "CD" : chr-toupper] -> 2
+
+  ;; Case insensitive string search using vector of characters as key
+  [search "abcd" #(#\eC #\eD) : chr-toupper] -> 2
+
 .SS Functions ref and refset
 
 .TP
diff --git a/txr.vim b/txr.vim
index c2482975..0f52d103 100644
--- a/txr.vim
+++ b/txr.vim
@@ -139,38 +139,38 @@ syn keyword txl_keyword contained s-ifsock s-irgrp s-iroth s-irusr
 syn keyword txl_keyword contained s-irwxg s-irwxo s-irwxu s-isgid
 syn keyword txl_keyword contained s-isuid s-isvtx s-iwgrp s-iwoth
 syn keyword txl_keyword contained s-iwusr s-ixgrp s-ixoth s-ixusr
-syn keyword txl_keyword contained search-regex search-str search-str-tree second
-syn keyword txl_keyword contained seek-stream set set-diff set-hash-userdata
-syn keyword txl_keyword contained set-sig-handler sethash setlogmask sh
-syn keyword txl_keyword contained sig-abrt sig-alrm sig-bus sig-check
-syn keyword txl_keyword contained sig-chld sig-cont sig-fpe sig-hup
-syn keyword txl_keyword contained sig-ill sig-int sig-io sig-iot
-syn keyword txl_keyword contained sig-kill sig-lost sig-pipe sig-poll
-syn keyword txl_keyword contained sig-prof sig-pwr sig-quit sig-segv
-syn keyword txl_keyword contained sig-stkflt sig-stop sig-sys sig-term
-syn keyword txl_keyword contained sig-trap sig-tstp sig-ttin sig-ttou
-syn keyword txl_keyword contained sig-urg sig-usr1 sig-usr2 sig-vtalrm
-syn keyword txl_keyword contained sig-winch sig-xcpu sig-xfsz sin
-syn keyword txl_keyword contained sixth size-vec some sort
-syn keyword txl_keyword contained source-loc source-loc-str span-str splice
-syn keyword txl_keyword contained split-str split-str-set sqrt stat
-syn keyword txl_keyword contained stream-get-prop stream-set-prop streamp string-cmp
-syn keyword txl_keyword contained string-extend string-lt stringp sub
-syn keyword txl_keyword contained sub-list sub-str sub-vec symacrolet
-syn keyword txl_keyword contained symbol-function symbol-name symbol-package symbol-value
-syn keyword txl_keyword contained symbolp symlink sys-qquote sys-splice
-syn keyword txl_keyword contained sys-unquote syslog tan third
-syn keyword txl_keyword contained throw throwf time time-fields-local
-syn keyword txl_keyword contained time-fields-utc time-string-local time-string-utc time-usec
-syn keyword txl_keyword contained tofloat toint tok-str tostring
-syn keyword txl_keyword contained tostringp tree-bind tree-case tree-find
-syn keyword txl_keyword contained trie-add trie-compress trim-str trunc
-syn keyword txl_keyword contained typeof unget-byte unget-char unless
-syn keyword txl_keyword contained unquote until upcase-str update
-syn keyword txl_keyword contained url-decode url-encode usleep uw-protect
-syn keyword txl_keyword contained vec vec-push vec-set-length vecref
-syn keyword txl_keyword contained vector vector-list vectorp when
-syn keyword txl_keyword contained while with-saved-vars zerop
+syn keyword txl_keyword contained search search-regex search-str search-str-tree
+syn keyword txl_keyword contained second seek-stream set set-diff
+syn keyword txl_keyword contained set-hash-userdata set-sig-handler sethash setlogmask
+syn keyword txl_keyword contained sh sig-abrt sig-alrm sig-bus
+syn keyword txl_keyword contained sig-check sig-chld sig-cont sig-fpe
+syn keyword txl_keyword contained sig-hup sig-ill sig-int sig-io
+syn keyword txl_keyword contained sig-iot sig-kill sig-lost sig-pipe
+syn keyword txl_keyword contained sig-poll sig-prof sig-pwr sig-quit
+syn keyword txl_keyword contained sig-segv sig-stkflt sig-stop sig-sys
+syn keyword txl_keyword contained sig-term sig-trap sig-tstp sig-ttin
+syn keyword txl_keyword contained sig-ttou sig-urg sig-usr1 sig-usr2
+syn keyword txl_keyword contained sig-vtalrm sig-winch sig-xcpu sig-xfsz
+syn keyword txl_keyword contained sin sixth size-vec some
+syn keyword txl_keyword contained sort source-loc source-loc-str span-str
+syn keyword txl_keyword contained splice split-str split-str-set sqrt
+syn keyword txl_keyword contained stat stream-get-prop stream-set-prop streamp
+syn keyword txl_keyword contained string-cmp string-extend string-lt stringp
+syn keyword txl_keyword contained sub sub-list sub-str sub-vec
+syn keyword txl_keyword contained symacrolet symbol-function symbol-name symbol-package
+syn keyword txl_keyword contained symbol-value symbolp symlink sys-qquote
+syn keyword txl_keyword contained sys-splice sys-unquote syslog tan
+syn keyword txl_keyword contained third throw throwf time
+syn keyword txl_keyword contained time-fields-local time-fields-utc time-string-local time-string-utc
+syn keyword txl_keyword contained time-usec tofloat toint tok-str
+syn keyword txl_keyword contained tostring tostringp tree-bind tree-case
+syn keyword txl_keyword contained tree-find trie-add trie-compress trim-str
+syn keyword txl_keyword contained trunc typeof unget-byte unget-char
+syn keyword txl_keyword contained unless unquote until upcase-str
+syn keyword txl_keyword contained update url-decode url-encode usleep
+syn keyword txl_keyword contained uw-protect vec vec-push vec-set-length
+syn keyword txl_keyword contained vecref vector vector-list vectorp
+syn keyword txl_keyword contained when while with-saved-vars zerop
 
 syn match txr_error "@[\t ]*[*]\?[\t ]*."
 syn match txr_nested_error "[^\t `]\+" contained