ybot_adt.xtm

;; lib-loading config
(if *impc:compiler:with-cache* (sys:load "libs/aot-cache/ybot_adt.xtm" 'quiet))
(sys:load-preload-check 'ybot_adt)
(define *xtmlib-ybot_adt-loaded* #t)

(impc:aot:suppress-aot-do (sys:load "libs/contrib/ybot/ybot_base.xtm"))
(impc:aot:insert-forms (sys:load "libs/contrib/ybot/ybot_base.xtm" 'quiet))

(impc:aot:insert-header "xtmybot_adt")
(impc:aot:import-ll "xtmybot_adt")


;;;;;;;;;;; Pair stuff - extends libs/core/adt.xtm ;;;;;;;;;;;;;;;;

(bind-func first:[!a,Pair{!a,!b}*,!a]*
  (lambda (p a)
    (tset! p 0 a)))

(bind-func second:[!b,Pair{!a,!b}*,!b]*
  (lambda (q b)
    (tset! q 1 b)))



;;;; More generalised associative array with comparator - extends libs/core/adt.xtm ;;;

(bind-func hash_find:[Pair{!w,!v}*,List{Pair{!w,!v}*}*,!w,[bool,!w,!w]*]*
  (lambda (hash key cmp)
    (if (null? hash)
        (convert null)
        (if (cmp (first (car hash)) key)
            (car hash)
            (hash_find (cdr hash) key cmp)))))


(bind-func hash_get:[!v,List{Pair{!w,!v}*}*,!w,[bool,!w,!w]*]*
  (lambda (hash key cmp)
    (if (null? hash)
        (convert null)
        (if (cmp (first (car hash)) key)
            (second (car hash))
            (hash_get (cdr hash) key cmp)))))


(bind-func hash_add:[!v,List{Pair{!w,!v}*}*,!w,[bool,!w,!w]*]*
  (lambda (hash key value cmp)
    (if (null? hash)
        (convert null)
        (set! hash (append hash (list (Pair key value)))))
    value))


(bind-func hash_set:[!v,List{Pair{!w,!v}*}*,!w,!v,[bool,!w,!w]*]*
  "set (or overwrite) value for key in dict (returns the old value)"
  (lambda (hash key value cmp)
    (if (null? hash)
        (convert null)
        (if (cmp (first (car hash)) key)
            (let ((oldval (second (car hash))))
              (tset! (car hash) 1 value)
              oldval)
            (if (null? (cdr hash))
                (begin (append hash (list (Pair key value)))
                       (convert null))
                (hash_set (cdr hash) key value cmp))))))


;;;;;;;;;; NonBlocking FIFO generic ;;;;;;;;
;; FIFO data type: data pointer, start, length, capacity, max_capacity
(bind-type FIFO <!a,i64,i64,i64,i64> (constructor? . #f) (printer? . #f))
(bind-func FIFO:[FIFO*,i64,i64]*
  (lambda (capacity max_capacity)
    (let ((output:FIFO* (alloc))
          (data (halloc capacity)))
      (tset! output 0 data)
      (tset! output 1 0)
      (tset! output 2 0)
      (tset! output 3 capacity)
      (tset! output 4 max_capacity)
      output)))

;; This is a hack to allow the compiler to know what the specialised type should be
(bind-func FIFO:[FIFO*,i64,i64,!a]*
  (lambda (capacity max_capacity dummy)
    (let ((output:FIFO* (alloc))
          (data (halloc capacity)))
      (set! dummy data)
      (tset! output 0 data)
      (tset! output 1 0)
      (tset! output 2 0)
      (tset! output 3 capacity)
      (tset! output 4 max_capacity)
      output)))


(bind-func data:[!a,FIFO*]* (lambda (q) (tref q 0)))
(bind-func data:[!a,FIFO*,!a]* (lambda (q value) (tset! q 0 value)))
(bind-func start:[i64,FIFO*]* (lambda (q) (tref q 1)))
(bind-func start:[i64,FIFO*,i64]* (lambda (q value) (tset! q 1 value)))
(bind-func size:[i64,FIFO*]* (lambda (q) (tref q 2)))
(bind-func size:[i64,FIFO*,i64]* (lambda (q value) (tset! q 2 value)))
(bind-func capacity:[i64,FIFO*]* (lambda (q) (tref q 3)))
(bind-func capacity:[i64,FIFO*,i64]* (lambda (q value) (tset! q 3 value)))

(bind-func FIFO_d:[void,FIFO*]*
  (lambda (q)
    (free (tref q 0))
    void))


(bind-func end:[i64,FIFO*]*
  (lambda (q)
    (modulo (+ (tref q 1) (tref q 2)) (tref q 3))))


(bind-func peek:[!a,FIFO*,i64]*
  (lambda (q n)
    (pref (tref q 0) (modulo (+ (tref q 1) n) (tref q 3)))))


(bind-func push:[void,FIFO*,!a]*
  (lambda (q val)
    (cond
     ((< (tref q 2) (capacity q))
      (pset! (tref q 0) (end q) val)
      (tset! q 2 (+ 1 (tref q 2)))
      void)
     ((<= (* 2 (tref q 3)) (tref q 4))
      (let* ((n:i64 (* 2 (tref q 3)))
             (i:i64 0)
             (old_data (tref q 0))
             (new_data (halloc n)))
        (dotimes (i n)
          (pset! new_data i (peek q i)))
        (tset! q 0 new_data)
        (free old_data)
        (tset! q 1 0)
        (tset! q 3 n)
        ;;(printf "Expanding FIFO capacity to %lld\n" n)
        (push q val)
        void))
     (else
      (pset! (tref q 0) (end q) val)
      (tset! q 1 (+ 1 (tref q 1)))
      void))))


(bind-func pop:[!a,FIFO*,bool*]*
  (lambda (q success)
    (cond
     ((< 0 (tref q 2))
      (let ((output (pref (tref q 0) (tref q 1))))
        (tset! q 1 (modulo (+ 1 (tref q 1)) (tref q 3)))
        (tset! q 2 (- (tref q 2) 1))
        (pset! success 0 #t)
        output))
     (else
      (pset! success 0 #f)
      (convert 0)))))
     

(bind-func print:[void,FIFO*]*
  (lambda (q)
    (printf "Queue %p\n" (cast q i8*))
    (printout ">>  ")
    (let ((i:i64 0))
      (dotimes (i (tref q 2))
        (printout (peek q (- (- (tref q 2) 1) i)))
        (printout "  ")))
    (println ">>")))


;;;;;;;;;;; NonBlocking Dynamic array ;;;;;;;;;;
;; DynamicArray type: data_ptr, size, capacity
(bind-type DynamicArray <!a,i64,i64> (printer? . #f) (constructor? . #f))
(bind-func DynamicArray:[DynamicArray*]*
  (lambda ()
    (let* ((output:DynamicArray* (alloc))
           (capacity:i64 256) (size:i64 0)
           (data (halloc capacity)))
      (tset! output 0 data)
      (tset! output 1 size)
      (tset! output 2 capacity)
      output)))

(bind-func DynamicArray_d:[void,DynamicArray*]*
  (lambda (v)
    (free (tref v 0))
    (tset! v 0 (convert 0))
    (tset! v 1 0)
    (tset! v 2 0)
    void))

(bind-func data:[!a,DynamicArray*]* (lambda (v) (tref v 0)))
(bind-func data:[!a,DynamicArray*,!a]* (lambda (v p) (tset! v 0 p)))
(bind-func size:[i64,DynamicArray*]* (lambda (v) (tref v 1)))
(bind-func size:[i64,DynamicArray*,i64]* (lambda (v n) (tset! v 1 n)))
(bind-func capacity:[i64,DynamicArray*]* (lambda (v) (tref v 2)))
(bind-func capacity:[i64,DynamicArray*,i64]* (lambda (v n) (tset! v 2 n)))

(bind-func push:[void,DynamicArray*,!a]*
  (lambda (v x)
    (cond
     ((< (tref v 1) (tref v 2)) ;; size < capacity
      (pset! (tref v 0) (tref v 1) x) ;; v[size] <-- x
      (tset! v 1 (+ (tref v 1) 1))
      void)
     (else
      (let* ((q (halloc (* (tref v 2) 2))) (i:i64 0))
        (dotimes (i (tref v 1))
          (pset! q i (pref (tref v 0) i)))
        (free (tref v 0))
        (tset! v 0 q)
        (tset! v 2 (* 2 (tref v 2)))
        (tset! v 1 (+ (tref v 1) 1))
        void)))))


(bind-func pop:[!a,DynamicArray*]*
  (lambda (v)
    (cond
     ((< 0 (tref v 1))
      (tset! v 1 (- (tref v 1) 1))
      (pref (tref v 0) (tref v 1)))
     (else (convert 0)))))
      

(bind-func at:[!a,DynamicArray*,i64]*
  (lambda (v i)
    (cond
     ((< i (tref v 1))
      (pref (tref v 0) i))
     (else
      (convert 0)))))


(bind-func at:[void,DynamicArray*,i64,!a]*
  (lambda (v i x)
    (cond
     ((< i (tref v 1))
      (pset! (tref v 0) i x) void)
     (else
      (let ((d:i64 (- i (tref v 1))) (j:i64 0))
        (dotimes (j d)
          (push v (convert 0)))
        (push v x)
        void)))))
          

(bind-func last:[!a,DynamicArray*]*
  (lambda (v)
    (cond
     ((< 0 (tref v 1))
      (pref (tref v 0) (- (tref v 1) 1)))
     (else (convert 0)))))


(bind-func clear:[void,DynamicArray*]*
  (lambda (v)
    (tset! v 1 0)
    void))


;; (bind-func print:[void,DynamicArray*]*
;;   (lambda (v:DynamicArray*)
;;     (let ((i:i64 0) (n:i64 (tref v 1)))
;;       (printout "[  ")
;;       (dotimes (i n)
;;          (printout (at v i))
;;          (printout "  "))
;;       (println "]"))))


(bind-func print:[void,DynamicArray{float*}*]*
  (lambda (v:DynamicArray{float*}*)
    (let ((i:i64 0) (n:i64 (tref v 1)))
      (printout "[  ")
      (dotimes (i n)
         (printout (at v i))
         (printout "  "))
      (println "]"))))

(bind-func print:[void,DynamicArray{i8*}*]*
  (lambda (v:DynamicArray{i8*}*)
    (let ((i:i64 0) (n:i64 (tref v 1)))
      (printout "[  ")
      (dotimes (i n)
         (printout (at v i))
         (printout "  "))
      (println "]"))))


(bind-func max_at:[i64,DynamicArray*]*
  (lambda (v)
    (let ((n:i64 (tref v 1)) (output:i64 0))
      (cond
       ((< 0 n)
        (let ((m (at v 0)) (i:i64 0))
          (dotimes (i n)
            (cond
             ((< m (at v i))
              (set! m (at v i))
              (set! output i)
              void)
             (else void))))
        void)
       (else
        void))
      output)))


(bind-func max:[!a,DynamicArray*]*
  (lambda (v)
    (at v (max_at v))))
          

(bind-func min_at:[i64,DynamicArray*]*
  (lambda (v)
    (let ((n:i64 (tref v 1)) (output:i64 0))
      (cond
       ((< 0 n)
        (let ((m (at v 0)) (i:i64 0))
          (dotimes (i n)
            (cond
             ((> m (at v i))
              (set! m (at v i))
              (set! output i)
              void)
             (else void))))
        void)
       (else
        void))
      output)))


(bind-func min:[!a,DynamicArray*]*
  (lambda (v)
    (at v (min_at v))))


(bind-func integrate:[!a,DynamicArray*,!a]*
  (lambda (v a)
    (let ((n:i64 (tref v 1)) (i:i64 0))
      (dotimes (i n)
        (set! a (+ a (at v i))))
      a)))
          
 
(bind-func mean:[!a,DynamicArray*]*
  (lambda (v)
    (let ((n:i64 (tref v 1)))
      (cond
       ((< 0 n)
        (/ (integrate v (convert 0)) (convert n)))
       (else (convert 0))))))
    

(bind-func sum:[!a,DynamicArray*]*
  (lambda (v)
    (integrate v (convert 0))))


(bind-func append:[void,DynamicArray*,!a,i64]*
  (lambda (v p sz)
    (let ((i:i64 0))
      (dotimes (i sz)
        (push v (pref p i)))
      void)))



;;;;;;;; end nonblocking dynamic array ;;;;;;;;


;; Arbitrary data
(bind-type Blob <i8*,i64>)
(bind-func data:[i8*,Blob*]* (lambda (blob) (tref blob 0)))
(bind-func data:[i8*,Blob*,i8*]* (lambda (blob ptr) (tset! blob 0 ptr)))
(bind-func size:[i64,Blob*]* (lambda (blob) (tref blob 1)))
(bind-func size:[i64,Blob*,i64]* (lambda (blob sz) (tset! blob 1 sz)))


;; Variant data type: data_ptr, byte_size, type_description
(bind-type Variant <i8*,i64,i8*> (constructor? . #f) (printer? . #f))
(bind-func Variant:[Variant*,i8*,i64,i8*]*
  (lambda (data size type)
    (let ((output:Variant* (alloc)))
      (tset! output 0 data)
      (tset! output 1 size)
      (tset! output 2 type)
      output)))

(bind-func data:[i8*,Variant*]* (lambda (v) (tref v 0)))
(bind-func data:[i8*,Variant*,i8*]* (lambda (v ptr) (tset! v 0 ptr)))
(bind-func byte_size:[i64,Variant*]* (lambda (v) (tref v 1)))
(bind-func byte_size:[i64,Variant*,i64]* (lambda (v sz) (tset! v 1 sz)))
(bind-func typestring:[i8*,Variant*]* (lambda (v) (tref v 2)))
(bind-func typestring:[i8*,Variant*,i8*]* (lambda (v str) (tset! v 2 str)))


(bind-func Variant:[Variant*,i64]*
  (lambda (n)
    (let* ((value:i64* (alloc))
           (data:i8* (bitcast value i8*)))
      (pset! value 0 n)
      (Variant:[Variant*,i8*,i64,i8*]* data 8 "i64"))))

(bind-func Variant:[Variant*,i32]*
  (lambda (n)
    (let* ((value:i32* (alloc))
           (data:i8* (bitcast value i8*)))
      (pset! value 0 n)
      (Variant:[Variant*,i8*,i64,i8*]* data 4 "i32"))))

(bind-func Variant:[Variant*,float]*
  (lambda (x)
    (let* ((value:float* (alloc))
           (data:i8* (bitcast value i8*)))
      (pset! value 0 x)
      (Variant:[Variant*,i8*,i64,i8*]* data 4 "float"))))

(bind-func Variant:[Variant*,double]*
  (lambda (x)
    (let* ((value:double* (alloc))
           (data:i8* (bitcast value i8*)))
      (pset! value 0 x)
      (Variant:[Variant*,i8*,i64,i8*]* data 8 "double"))))

(bind-func Variant:[Variant*,String*]*
  (lambda (s)
    (let ((sz:i64 (+ (length s) 1))
          (data:i8* (cstring s)))
      (Variant:[Variant*,i8*,i64,i8*]* data sz "cstr"))))

(bind-func Variant:[Variant*,Blob*]*
  (lambda (blob)
    (Variant:[Variant*,i8*,i64,i8*]* (data blob) (size blob) "blob")))
    

(bind-func unbox:[i64,Variant*]*
  (lambda (var)
    (cond
     ((= 0:i32 (strcmp (tref var 2) "i64"))
      (pref (bitcast (tref var 0) i64*) 0))
     ((= 0:i32 (strcmp (tref var 2) "i32"))
      (i32toi64 (pref (bitcast (tref var 0) i32*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "float"))
      (ftoi64 (pref (bitcast (tref var 0) float*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "double"))
      (dtoi64 (pref (bitcast (tref var 0) double*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "cstr"))
      (strlen (tref var 2)))
     ((= 0:i32 (strcmp (tref var 2) "blob"))
      (tref var 1))
     (else -1))))

(bind-func unbox:[i32,Variant*]*
  (lambda (var)
    (cond
     ((= 0:i32 (strcmp (tref var 2) "i32"))
      (pref (bitcast (tref var 0) i32*) 0))
     ((= 0:i32 (strcmp (tref var 2) "i64"))
      (i64toi32 (pref (bitcast (tref var 0) i64*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "float"))
      (ftoi32 (pref (bitcast (tref var 0) float*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "double"))
      (dtoi32 (pref (bitcast (tref var 0) double*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "cstr"))
      (i64toi32 (strlen (tref var 2))))
     ((= 0:i32 (strcmp (tref var 2) "blob"))
      (i64toi32 (tref var 1)))
     (else -1))))

(bind-func unbox:[float,Variant*]*
  (lambda (var)
    (cond
     ((= 0:i32 (strcmp (tref var 2) "float"))
      (pref (bitcast (tref var 0) float*) 0))
     ((= 0:i32 (strcmp (tref var 2) "i32"))
      (i32tof (pref (bitcast (tref var 0) i32*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "i64"))
      (i64tof (pref (bitcast (tref var 0) i64*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "double"))
      (dtof (pref (bitcast (tref var 0) double*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "cstr"))
      (i64tof (strlen (tref var 2))))
     ((= 0:i32 (strcmp (tref var 2) "blob"))
      (i64tof (tref var 1)))
     (else -1.0:float))))


(bind-func unbox:[double,Variant*]*
  (lambda (var)
    (cond
     ((= 0:i32 (strcmp (tref var 2) "double"))
      (pref (bitcast (tref var 0) double*) 0))
     ((= 0:i32 (strcmp (tref var 2) "i32"))
      (i32tod (pref (bitcast (tref var 0) i32*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "i64"))
      (i64tod (pref (bitcast (tref var 0) i64*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "float"))
      (ftod (pref (bitcast (tref var 0) float*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "cstr"))
      (i64tod (strlen (tref var 2))))
     ((= 0:i32 (strcmp (tref var 2) "blob"))
      (i64tod (tref var 1)))
     (else -1.0:double))))


(bind-func unbox:[String*,Variant*]*
  (lambda (var)
    (cond
     ((= 0:i32 (strcmp (tref var 2) "cstr"))
      (String (tref var 0)))
     (else (String (tref var 2))))))


(bind-func unbox:[Blob*,Variant*]*
  (lambda (var)
    (cond
     ((= 0:i32 (strcmp (tref var 2) "blob"))
      (Blob (tref var 0) (tref var 1)))
     (else (Blob (tref var 2) (strlen (tref var 2)))))))


(bind-func isi32:[bool,Variant*]*
  (lambda (v)
    (= (strcmp (typestring v) "i32") 0:i32)))


(bind-func isi64:[bool,Variant*]*
  (lambda (v)
    (= (strcmp (typestring v) "i64") 0:i32)))

(bind-func isfloat:[bool,Variant*]*
  (lambda (v)
    (= (strcmp (typestring v) "float") 0:i32)))

(bind-func isdouble:[bool,Variant*]*
  (lambda (v)
    (= (strcmp (typestring v) "double") 0:i32)))

(bind-func isBlob:[bool,Variant*]*
  (lambda (v)
    (= (strcmp (typestring v) "blob") 0:i32)))


(bind-func isString:[bool,Variant*]*
  (lambda (v)
    (= (strcmp (typestring v) "cstr") 0:i32)))


(bind-func print:[void,Variant*]*
  (lambda (var)
    (cond 
     ((= 0:i32 (strcmp (tref var 2) "double"))
      (printf "double: %lf" (pref (bitcast (tref var 0) double*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "i32"))
      (printf "i32: %ld" (pref (bitcast (tref var 0) i32*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "i64"))
      (printf "i64: %lld" (pref (bitcast (tref var 0) i64*) 0)))
     ((= 0:i32 (strcmp (tref var 2) "float"))
      (printf "float: %f" (ftod (pref (bitcast (tref var 0) float*) 0))))
     ((= 0:i32 (strcmp (tref var 2) "cstr"))
      (printf "string: %s" (tref var 0)))
     ((= 0:i32 (strcmp (tref var 2) "blob"))
      (printf "Binary data length %ld" (tref var 1)))
     (else (printf "unknown typestring: %s" (tref var 2))))
    void))

;;;;;;;;;;;;;;;;;;;;


(bind-func caar:[!a,List{!a}*]* (lambda (x) (car (car x))))
(bind-func cadr:[!a,List{!a}*]* (lambda (x) (car (cdr x))))
(bind-func caaar:[!a,List{!a}*]* (lambda (x) (car (car (car x)))))
(bind-func caadr:[!a,List{!a}*]* (lambda (x) (car (car (cdr x)))))
(bind-func caddr:[!a,List{!a}*]* (lambda (x) (car (cdr (cdr x)))))
(bind-func caaaar:[!a,List{!a}*]* (lambda (x) (car (car (car (car x))))))
(bind-func caaadr:[!a,List{!a}*]* (lambda (x) (car (car (car (cdr x))))))
(bind-func caaddr:[!a,List{!a}*]* (lambda (x) (car (car (cdr (cdr x))))))
(bind-func cadddr:[!a,List{!a}*]* (lambda (x) (car (cdr (cdr (cdr x))))))
(bind-func caddddr:[!a,List{!a}*]* (lambda (x) (car (cdr (cdr (cdr (cdr x)))))))


(impc:aot:insert-footer "xtmybot_adt")