Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/lisp/eulisp/mpfeel.lha/MPFeel/Modules/heapv2.em

Text File | 1992-10-06 | 21.1 KB | 713 lines

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                           ;;
;;  EuLisp Module                     Copyright (C) University of Bath 1991  ;;
;;                                                                           ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmodule heapv2
  (futures
   threads
   semaphores
   arith
   lists
   extras
   vectors
   list-operators
   streams
 ) ()


(setq lista1 nil)
(setq lista2 nil)

(setq seed 253)
(setq seed2 867)

(defun >= (x y)
  (not (< x y))
)

(defun <= (x y)
  (not (> x y))
)

(defun random100 ()
   (progn
      (setq seed (modulo (+ (* seed 1213) 277) 149))
      (modulo seed 100)
   )
)

(defun random30 ()
   (progn
      (setq seed2 (modulo (+ (* seed2 3247) 913) 97))
      (+ (modulo seed2 13) 1)
   )
)


(defun create_pet (n)
   (create_pet_aux () n 0)
)


(defun cont (x y)
  (if (equal x nil)
      nil
   (if (or
          (and (>= (car y) (caar x)) (< (car y) (+ (caar x) (cdar x))))
          (and (>= (caar x) (car y)) (< (caar x) (+ (car y) (cdr y))))
        )
      t
      (cont (cdr x) y)
   )
  )
)


(defun create_pet_aux (x n c)
   (if (not (< c n))
      x
    (prog (a b)
loop1
      (setq a (random100))
      (setq b (random30))
      (if (> (+ a b) 100) (go loop1) nil)
      (if (cont x (cons a b)) (go loop1)
                 (if (= 0 (modulo c 2))
                            (progn
                              (setq lista1 (append lista1 (list (cons a b))))
                              (create_pet_aux (append x (list (cons a b))) n (+ c 1))
                            )
                            (progn
                              (setq lista2 (append lista2 (list (cons a b))))
                              (create_pet_aux (append x (list (cons a b))) n (+ c 1))
                            )
                 )
      )
    )
  )
)

(defun scheduler (n)
         (create_pet n)
         (print lista1)
         (print lista2)
     (progn (future (process)) (process2))
)

(defun process ()
     (setq item (car lista))
     (setq lista (cdr lista))
     (if (null lista) (setq fin t) (setq fin f))
     (insblk (car item) (cdr item))
     (if fin nil (process))
)

(defun process2 ()
    (setq item (car lista2))
    (setq lista2 (cdr lista2))
    (if (null lista2) (setq fin t) (setq fin f))
    (insblk (car item) (cdr item))
    (if fin nil (process2))
)


;;; Rutinas de test de las inserciones y supresiones en el arbol.
;;; Test(n) genera n inserciones aleatorias,haciendo una supresion aleatoria
;;; cada 4 inserciones a partir de la segunda.

(defun test (n)
  (test-aux (create_pet n) 0)
)

(defun test-aux (x n)
    (print "*************************************")
    (print (car x))
    (insblk (caar x) (cdar x))
    (print tuple_root)
    (if (= (modulo n 4) 2)
        (progn
          (print "####################################")
      (setq z (random30))
      (print z)
          (getblk z)
      (print tuple_root)
        )
        nil
    )
    (if (equal (cdr x) nil)
        nil
        (test-aux (cdr x) (+ n 1))
    )
)

;;; Constant definition

(defconstant block_size 5)
(defconstant b_lock 0)
(defconstant b_left 1)
(defconstant b_right 2)
(defconstant b_addr 3)
(defconstant b_len 4)

(defconstant l_child t)
(defconstant r_child nil)

(defconstant heap_size 100)
(defconstant heap_base_addr 0)
(defconstant extra_big (+ 1 heap_size))


;;; Function definition

(defun free (node)
 (print "entro en free")
 (if (not (= 1 (vector-ref node b_lock)))
      (progn
    (print "******************************************************")
    (print "Trying to free a node that is not locked")
    (print "******************************************************")
      )
    nil
 )
 (vector-ref-updator node b_lock 0)
 (print "salgo de free")
)

(defun <= (x y) (not (> x y)))    ;;; Do these functions exist ???
(defun >= (x y) (not (< x y)))

;;; Nodes are marked when they are accesed by the functions left and right.
;;; They are not marked by the functions leftw and rightw (the process
;;; just waits for them to be free before operating on them).

(defun left  (x)
 (prog (var)
    (print "Entrando en left y la x vale : ")
    (print x)
    (if (not (= 1 (vector-ref x b_lock)))
       (progn
        (print "***********************************************")
        (print "Trying to get the left child without locking the parent")
        (print "***********************************************")
       )
    nil
    )
       (setq var (vector-ref x b_left))
       (if (null var) (return nil) nil)
lb     (cond ( (= (vector-ref var b_lock) 0)
               (vector-ref-updator var b_lock 1)
               (return var)
             )
             ( t (go lb))
       )
 )
)

(defun leftw  (x)
 (prog (var)
       (setq var (vector-ref x b_left))
       (if (null var) (return nil) nil)
lb     (cond ( (= (vector-ref var b_lock) 0)
               (return var)
             )
             ( t (go lb))
       )
 )
)

(defun right  (x)
 (prog (var)
    (print "Entrando en right la x vale : ")
    (print x)
    (if (not (= 1 (vector-ref x b_lock)))
       (progn
        (print "***********************************************")
        (print "Trying to get the right child without locking the parent")
        (print "***********************************************")
       )
    nil
    )
       (setq var (vector-ref x b_right))
       (if (null var) (return nil) nil)
lb     (cond ( (= (vector-ref var b_lock) 0)
               (vector-ref-updator var b_lock 1)
               (return var)
             )
             ( t (go lb))
       )
 )
)


(defun rightw  (x)
 (prog (var)
       (setq var (vector-ref x b_right))
       (if (null var) (return nil) nil)
lb     (cond ( (= (vector-ref var b_lock) 0)
               (return var)
             )
             ( t (go lb))
       )
 )
)


(defun addr  (x)    (vector-ref x b_addr  ))
(defun len   (x)    (vector-ref x b_len   ))


(defun leftkkk  (x y)  (vector-ref-updator x b_left  y))
(defun rightkkk (x y)  (vector-ref-updator x b_right y))
(defun addrkkk  (x y)  (vector-ref-updator x b_addr  y))
(defun lenkkk   (x y)  (vector-ref-updator x b_len   y))

(defun to_the_left_of (a b)
    (< (addr a) (addr b)))

(defun coalesces (left right)
    (= (+ (addr left) (len left)) (addr right)))

(defun ok4size (parent child)
    (>= (len parent) (len child)))

(defun add2len (old new)
    (lenkkk old (+ (len old) (len new))))

(defun fixparent (p waslft new)         ; update either left or right of a node
    (if waslft (leftkkk p new )
           (rightkkk p new)
    )
)

; pretend that root is arbitrarily large to get insert to coalesce correctly on
; first real node

(defun make_block (base length)
    (let ((new (make-vector block_size nil)))
          (vector-ref-updator new b_lock 0)
          (addrkkk new base)
          (lenkkk new length)
          new
    )
)

(defun setup_tuple_heap ()
    (setq tuple_root (make_block (+ heap_base_addr heap_size) extra_big))
    (leftkkk tuple_root (make_block heap_base_addr heap_size))

    (setq sem (make-semaphore))
    (initialize-semaphore sem)

;;; Inicialitzar el semafor de l'arrel, posteriorment caldra fer servir un
;;; semafor de veritat.

)

(setup_tuple_heap)    ; set up made when loading the module

(defun insblk (adr leng)
    (setq v (make-vector 5 nil))
    (vector-ref-updator v b_lock 1)        ;the block to be inserted is locked
    (addrkkk v adr)
    (lenkkk v leng)

;;; Wait del semafor de l'arrel de l'arbre.De moment no es fa com cal.

    (open-semaphore sem)

    (insert tuple_root l_child (left tuple_root) v)
)

(defun insertfromroot (new)
   (rightkkk new nil)
   (leftkkk new nil)

;;; Wait del semafor de l'arrel de l'arbre.Solucio temporal.

    (open-semaphore sem)

    (insert tuple_root l_child (left tuple_root ) new )
)

(defun getblk(size)

;;; Wait del semafor de l'arrel de l'arbre.Encara no ben fet.

 (open-semaphore sem)

 (let ((l_son (left tuple_root)))
  (if (null l_son)
    (progn
      (print "Sorry,no memory left")

    (close-semaphore sem)
;;; Fer el signal del semafor de l'arrel.

      nil
    )
    (progn
          (cond ((> size (len l_son))
               (print "No large enough block exists.")
               (print " Max : ")
               (print (len l_son))
               (print " Request : ")
               (print size)

                   (free l_son)
    (close-semaphore sem)

;;; Signal del semafor de l'arrel,treure in-use fill esquerre.

               nil
        )
            (t
               (getblk1 size l_son tuple_root t)
            )
           )
    )
   )
 )
)
(defun getblk1 (size ptr last waslft)
                     ; get a block of size from a descendant of ptr if
             ; possible, or split ptr otherwise

    (let ((l (left ptr)) (r (right ptr)))
      (cond ((and (not (null l))
          (<= size (len l)))
             (if (= 100 (addr last)) (close-semaphore sem) (free last))
             (if (not (null r)) (free r) nil)
             ;;;en aquest punt alliberar r i last
         (getblk1 size l ptr t))               ; get from left hand child
        ((and (not (null r))
          (<= size (len r)))
             ;;; en aquest punt alliberar last i l
             (if (not (null l)) (free l) nil)
             (if (= 100 (addr last)) (close-semaphore sem) (free last))
         (getblk1 size r ptr nil))             ; get from right hand child
        (t
             (if (not (null l)) (free l) nil)
             (if (not (null r)) (free r) nil)
             ;;; en aquest punt alliberar l i r
         (splitblk size ptr last waslft))
    )
      )
)



(defun splitblk (size ptr last waslft) ; allocate a block of size from the end
                       ; of ptr and make ptr smaller
    (let* ((l (len ptr)) (over (- l size))
       (new (make_block (+ (addr ptr) over) size)))
;;; atencio, new es  un node que es fabrica nomes per a retornar a l'usuari
;;; pero que mai no s'incorpora a l'arbre...No cal marcar-lo ni res.
      (cond ((= 0 over)             ; asked for the whole block
         (delfixup last waslft (left ptr) (right ptr))
;;;Aqui no cal alliberar res
         ; should perhaps null out left and right in ptr
         (leftkkk ptr 'void)
         (rightkkk ptr 'void)
             (free ptr) ;innecesari,ningu hauria de poder arribar a ptr mai mes
;;; Aqui alliberar ptr
         new)
        (t
         (lenkkk ptr over)             ; make ptr smaller
         (reheapify last waslft ptr)
         new)
    )
    )
)


(defun reheapify (parent waslft ptr)
    ; ptr may be too small, but is ok for addressing
    (print "Entro en reheapify")
    (print parent)
    (print ptr)
    (let* ((a (left ptr)) (b (right ptr)) (plen (len ptr))
       (abig (and (not (null a)) ; abig true if left child too big
              (> (len a) plen)))
       (bbig (and (not (null b)) ; bbig true if right child too big
              (> (len b) plen))))
      (cond ((not abig)
         (cond ((not bbig)
                    (if (not (null a)) (free a) nil)
                    (if (not (null b)) (free b) nil)
                    (free ptr)
            (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
             nil
            ) ; ptr was actually ok
        (t
            ; right hand child is bigger, left isn't
         (fixparent parent waslft b)     ; parent points to old right
             (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
         (leftkkk ptr a)               ; hang old left onto left of ptr
         (if (not (null a)) (free a) nil)
         (rightkkk ptr (leftw b))       ; and left of old right on right
         (leftkkk b ptr)               ; and put ptr as left of old right
         (reheapify b l_child ptr))))      ; now check that
        (t                                 ; left child is bigger than ptr
         (cond ((not bbig)                 ; and right isn't
            (fixparent parent waslft a) ; parent points to old left
            (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
            (rightkkk ptr b)       ; hang old right onto right of ptr
            (if (not (null b)) (free b) nil)
            (leftkkk ptr (rightw a))  ; and right of old left on left
            (rightkkk a ptr)       ; and put ptr as right of old left
            (reheapify a r_child ptr))    ; now check that
           ; both a children are bigger, so must put correct one on top
           ((> (len a) (len b))         ; left is bigger than right
            (fixparent parent waslft a) ; see comments above
            (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
            (rightkkk ptr b)
            (if (not (null b)) (free b) nil)
            (leftkkk ptr (rightw a))
            (rightkkk a ptr)
            (reheapify a r_child ptr))
           (t
            (fixparent parent waslft b)
            (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
            (leftkkk ptr a)
            (if (not (null a)) (free a) nil)
            (rightkkk ptr (leftw b))
            (leftkkk b ptr)
            (reheapify b l_child ptr)
           )
         )
        )
     )
      )
)




(defun delfixup (parent waslft a b)
    (print "entro en delfixup")
    (print parent)
    (print a)
    (print b)
    ; we've deleted a node, so we've got a dangling pointer and two orphans.
    (cond ((null a)
          ;;; no cal alliberar a doncs si es null llavors no hi ha in_use...
                                       ; no left child
       (if (null b)
            ;;; el mateix d'abans aplicat a b
               (progn
            (fixparent parent waslft nil) ; no children so make into a leaf
                (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
               )
               (progn
            (fixparent parent waslft b)   ; attach old right child
                (free b)
                (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
               )
           )
          )
               ;;; alliberar parent i b si no era null
               ;;; s'ha fet introduint progn per a sequenciar...
      (t
       (if (null b)
               ;;; no alliberar b,  doncs era null
               (progn
            (fixparent parent waslft a) ; no right child
                (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
            (free a)
               )
               ;;; alliberar parent i a ; tambe fet amb progn
            ; hard case, there are two children, so do a rotate
        (cond ((> (len a) (len b))    ; old left is bigger, so
           (fixparent parent waslft a)   ; dangling now to old left
                (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
                   ;;; alliberar parent
           (delfixup a r_child (right a) b)) ; fixup right of old left
                                         ; wrt old right of old left
                                         ; and old right

          (t                             ; old right is bigger, so
           (fixparent parent waslft b)   ; dangling now to old right
                (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
           ;;; alliberar parent
           (delfixup b l_child a (left b)))))))
     (print "salgo de delfixup")
)


(defun delfixupnm (parent waslft a b)
    (print "entro en delfixupnm")
    (print parent)
    (print a)
    (print b)
    ; we've deleted a node, so we've got a dangling pointer and two orphans.
    (cond ((null a)
          ;;; no cal alliberar a doncs si es null llavors no hi ha in_use...
                                       ; no left child
       (if (null b)
            ;;; el mateix d'abans aplicat a b
               (progn
            (fixparent parent waslft nil) ; no children so make into a leaf
               )
               (progn
            (fixparent parent waslft b)   ; attach old right child
               )
           )
          )
               ;;; alliberar parent i b si no era null
               ;;; s'ha fet introduint progn per a sequenciar...
      (t
       (if (null b)
               ;;; no alliberar b,  doncs era null
               (progn
            (fixparent parent waslft a) ; no right child
               )
               ;;; alliberar parent i a ; tambe fet amb progn
            ; hard case, there are two children, so do a rotate
        (cond ((> (len a) (len b))    ; old left is bigger, so
           (fixparent parent waslft a)   ; dangling now to old left
                   ;;; alliberar parent
           (delfixupnm a r_child (rightw a) b)) ; fixup right of old left
                                         ; wrt old right of old left
                                         ; and old right

          (t                             ; old right is bigger, so
           (fixparent parent waslft b)   ; dangling now to old right
           ;;; alliberar parent
           (delfixupnm b l_child a (leftw b)))))))
     (print "salgo de delfixupnm")
)

            ; fixup left of old right wrt old left and old left of old right

; insert is the hardest of all. When inserting a block it may coalesce with
; 0, 1 or 2 existing blocks. If we have just performed a coalescence then the
; other coalescing block (if it exists) is in one of the children; found by
; leftc or rightc.

(defun leftc (parent waslft node end_addr) ; find a block ending at end_addr
    ;starting from node. If such a block exists it is the rightmost descendant,
    ;and its left child (if any) can be spliced in in its place.

    (cond ((null node) nil)
      ((= (+ (addr node) (len node)) end_addr)    ; it does coalesce
      (fixparent parent waslft (leftw node)) ;delete node and reconnect left
       node)
      (t
       (leftc node r_child (rightw node) end_addr)
          )
  )
)

(defun rightc (parent waslft node start_addr) ;find a block starting at
                          ;start_addr from node, going left
    (cond ((null node) nil)
      ((= (addr node) start_addr)          ; it does coalesce
       (fixparent parent waslft (rightw node)) ;delete node and reconnect right
       node)
      (t
       (rightc node l_child (leftw node) start_addr)
          )
    )
)

; partition takes a tree (node), and a pivot element. It returns a tree, the
; root of which is pivot (with any coalescing blocks added to it), and whose
; children are correct wrt the root.

(defun partition (node pivot)
    ; partition returns a node whose left and right children are correct
    ; the node is the (modified) pivot
    (print "entro en partition")
    (print node)
    (cond ((null node)
       (leftkkk pivot nil)
       (rightkkk pivot nil)
       pivot)
      ((to_the_left_of node pivot)
       (cond ((coalesces node pivot) ; pivot joins onto right end of node
          (add2len node pivot)   ; merge node into pivot
          (let ((rc (rightc node r_child (rightw node)
                    (+ (addr node) (len node)))))
            ; rc modifies right branch in place
            (cond ((not (null rc)) ;rc goes on right of new
               (add2len node rc))))
          node) ; node now has correct left and right children
         (t                     ; node clear to left of pivot
          ; thus the left children of node are ok
          (let ((part (partition (rightw node) pivot)))
         ; now transfer the left child of part to be right child of node
            (rightkkk node (leftw part))
            (leftkkk part node) ; and make node the left child of part
            part))))
      (t
       (cond ((coalesces pivot node)  ; new joins to left of node
          (addrkkk node (addr pivot)) ; node now begins at new
          (add2len node pivot)            ; merge new into node
          (let ((lc (leftc node l_child (leftw node)
                   (addr node))))
            (cond ((not (null lc)) ; lc goes on left of node
               (addrkkk node (addr lc))
               (add2len node lc))))
          node)
         (t                     ; node clear to right of pivot
          ; thus the right children of node are ok
          (let ((part (partition (leftw node) pivot)))
           ; now transfer the right child of part to be left child of node
            (leftkkk node (rightw part))
            (rightkkk part node) ; and make node the right child of part
            part)))))
)

(defun insert (parent waslft node new)
    (cond ((null node)  ; make new into a leaf
       (fixparent parent waslft new)
;;; alliberem parent,no cal alliberar node perque es nul
           (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
       (free new)    ;;; bloc a insertar,esta marcat
      )
      ((and (not (coalesces node new)) ; if it coalesces we call partition
        (not (coalesces new node)) ; lazy, but the loss isn't much
        (> (len node) (len new))) ; we aren't big enough
           ;;;aqui es pot alliberar parent, abans de fer el cond
           (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
       (cond ((< (addr new) (addr node)) ; node goes on left of new
          (insert node l_child (left node) new))
         (t   ; new on the left of node
          (insert node r_child (right node) new))))
      (t
; could be a coalescence
; new is now not smaller than node, so put it in place of node,
; partition the appropriate descendent, and fix up.
; we insert as soon as we can so thatif a coalescence occurs
; there's a chance we still fit.
           (free new)
           (free node)
       (let ((p (partition node new)))
         (cond ((ok4size parent p)
            (fixparent parent waslft p)
;;; alliberar parent
           (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
           ) ;we fit here,so fixup and leave
           (t
            (delfixupnm parent waslft (left p) (right p)) ; delete us
           (if (= 100 (addr parent)) (close-semaphore sem) (free parent))
                    (vector-ref-updator p b_lock 1)
                    (print " >>>>>>>>>>>>>>>>> reinserto <<<<<<<<<<<<<<<")
                    (insertfromroot p)            ; and start again
           )
         )
       )
      )
    )
)

; note that the reinsertion from root cannot cause a coalescence, and thus
; simplified code could be used. fix it later maybe.


(export insblk getblk test scheduler)

)