core/math/order/order.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel kernel.private math ;
   4 IN: math.order
   5
   6 SYMBOL: +lt+
   7 SYMBOL: +eq+
   8 SYMBOL: +gt+
   9
  10 : invert-comparison ( <=> -- >=< )
  11     ! Can't use case, index or nth here
  12     dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
  13
  14 GENERIC: <=> ( obj1 obj2 -- <=> )
  15
  16 : >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
  17
  18 <PRIVATE
  19
  20 ! Defining a math generic for comparison forces a single math
  21 ! promotion, and speeds up comparisons on numbers.
  22 : (real<=>) ( x y -- <=> )
  23     2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
  24
  25 MATH: real<=> ( x y -- <=> )
  26 M: fixnum real<=> { fixnum fixnum } declare (real<=>) ; inline
  27 M: bignum real<=> { bignum bignum } declare (real<=>) ; inline
  28 M: float real<=> { float float } declare (real<=>) ; inline
  29 M: real real<=> (real<=>) ; inline
  30
  31 PRIVATE>
  32
  33 M: real <=> real<=> ; inline
  34
  35 GENERIC: before? ( obj1 obj2 -- ? )
  36 GENERIC: after? ( obj1 obj2 -- ? )
  37 GENERIC: before=? ( obj1 obj2 -- ? )
  38 GENERIC: after=? ( obj1 obj2 -- ? )
  39
  40 M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline
  41 M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline
  42 M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; inline
  43 M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; inline
  44
  45 M: real before? ( obj1 obj2 -- ? ) < ; inline
  46 M: real after? ( obj1 obj2 -- ? ) > ; inline
  47 M: real before=? ( obj1 obj2 -- ? ) <= ; inline
  48 M: real after=? ( obj1 obj2 -- ? ) >= ; inline
  49
  50 GENERIC: min ( obj1 obj2 -- obj )
  51 GENERIC: max ( obj1 obj2 -- obj )
  52
  53 M: object min [ before? ] most ; inline
  54 M: object max [ after? ] most ; inline
  55
  56 : clamp ( x min max -- y ) [ max ] dip min ; inline
  57
  58 : between? ( x y z -- ? )
  59     pick after=? [ after=? ] [ 2drop f ] if ; inline
  60
  61 : [-] ( x y -- z ) - 0 max ; inline
  62
  63 : compare ( obj1 obj2 quot -- <=> ) bi@ <=> ; inline