From d8f258d47e8b14607268cf8138d8895860066b70 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Wed, 18 Sep 2013 18:17:45 -0700
Subject: [PATCH] dlists: adding push-before and push-sorted.

---
 basis/dlists/dlists-tests.factor |  7 ++++++-
 basis/dlists/dlists.factor       | 31 ++++++++++++++++++++++++++++---
 2 files changed, 34 insertions(+), 4 deletions(-)

diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor
index a4879d6ea3..5c650adabe 100644
--- a/basis/dlists/dlists-tests.factor
+++ b/basis/dlists/dlists-tests.factor
@@ -1,5 +1,5 @@
 USING: accessors arrays classes deques dlists kernel locals
-math tools.test ;
+math sequences tools.test ;
 IN: dlists.tests
 
 [ t ] [ <dlist> deque-empty? ] unit-test
@@ -148,3 +148,8 @@ TUPLE: my-node < dlist-link { obj fixnum } ;
 ] unit-test
 
 
+{ DL{ 0 1 2 3 4 } } [
+    <dlist> [
+        { 3 2 4 1 0 } [ swap push-sorted drop ] with each
+    ] keep
+] unit-test
diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index 297e5a5c25..251ab78e7e 100644
--- a/basis/dlists/dlists.factor
+++ b/basis/dlists/dlists.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2007, 2009 Mackenzie Straight, Doug Coleman,
-! Slava Pestov.
+! Slava Pestov, John Benediktsson.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators combinators.short-circuit
-deques fry hashtables kernel parser search-deques sequences
-summary vocabs.loader ;
+deques fry hashtables kernel math.order parser search-deques
+sequences summary vocabs.loader ;
 IN: dlists
 
 TUPLE: dlist-link { prev maybe{ dlist-link } } { next maybe{ dlist-link } } ;
@@ -192,6 +192,31 @@ M: dlist clear-deque ( dlist -- )
 M: dlist clone
     <dlist> [ '[ _ push-back ] dlist-each ] keep ;
 
+<PRIVATE
+
+: (push-before-node) ( obj dlist-node -- new-dlist-node )
+    [ [ prev>> ] keep <dlist-node> ] keep {
+        [ prev>> [ next<< ] [ drop ] if* ]
+        [ prev<< ]
+        [ drop ]
+    } 2cleave ; inline
+
+: push-before-node ( obj dlist-node dlist -- new-dlist-node )
+    2dup front>> eq? [
+        nip push-front*
+    ] [
+        drop (push-before-node)
+    ] if ; inline
+
+PRIVATE>
+
+: push-before ( ... obj dlist quot: ( ... obj -- ... ? ) -- ... dlist-node )
+    [ obj>> ] prepose over [ dlist-find-node ] dip swap
+    [ swap push-before-node ] [ push-back* ] if* ; inline
+
+: push-sorted ( obj dlist -- dlist-node )
+    dupd [ before? ] with push-before ;
+
 INSTANCE: dlist deque
 
 SYNTAX: DL{ \ } [ >dlist ] parse-literal ;