;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: general-utilities.lsp
;;;;    System: 
;;;;    Author: Shawn Nicholson
;;;;   Created: July 15, 2002 16:38:35
;;;;   Purpose: 
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Sunday, November 17, 2002 at 13:01:23 by nicholson
;;;; ---------------------------------------------------------------------------

(in-package :text-editor-case-display)


(defun pretty-print-to-string (form &optional (width 40))
  "Pretty-prints a LISP expression to a string.  The output is constrained
   to a width that is the number of characters specified by width."
  (let ((*print-right-margin* width)
        (*package* (find-package :data)))
    (remove-leading-newline
     (with-output-to-string (s)
       (pprint form s)))))

(defun remove-leading-newline (string)
   (if (eq (elt string 0) #\newline)
      (subseq string 1)
      string))


(defun mentions (expression elem &key (test 'equal))
  ;; Returns true if elem is mentioned anywhere in expression
  ;;  Similar to "member" except is recursive
  (cond ((null expression) nil)
        ((funcall test expression elem)
         expression)
        ((not (listp expression))
         nil)
        (t
         (or (mentions (first expression) elem :test test)
             (mentions (rest expression) elem :test test)))))


(defun insert (item sequence pos)
  "Inserts item in sequence at position pos"
  (cond ((> pos (length sequence))
         (append sequence (list item)))
        ((= 0 pos)
         (cons item sequence))
        (t
         (cons (first sequence)
               (insert item (rest sequence) (- pos 1))))))
            



(defun contained-in-box? (pos box)
  "Returns true if CG position is inside the CG box"
  (and (>= (cg:position-x pos) (cg:box-left box))
       (<= (cg:position-x pos) (cg:box-right box))
       (>= (cg:position-y pos) (cg:box-top box))
       (<= (cg:position-y pos) (cg:box-bottom box))))



(defun boxes-intersect? (box1 box2)
  "Takes two CG boxes and returns true if they intersect at all"
  (let ((uL1 (cg:box-top-left box1))
        (uR1 (cg:box-top-right box1))
        (bL1 (cg:box-bottom-left box1))
        (uL2 (cg:box-top-left box2))
        (uR2 (cg:box-top-right box2))
        (bL2 (cg:box-bottom-left box2)))
    (not (or (< (cg:position-x uR1) (cg:position-x uL2))
             (> (cg:position-x uL1) (cg:position-x uR2))
             (< (cg:position-y bL1) (cg:position-y uL2))
             (> (cg:position-y uL1) (cg:position-y bL2))))))
          
          
(defun box-contained-in? (box1 box2)
  "Takes two CG boxes and returns true if box1 is completely inside box2"
  (and (contained-in-box? (cg:box-bottom-left box1) box2)
       (contained-in-box? (cg:box-bottom-right box1) box2)
       (contained-in-box? (cg:box-top-right box1) box2)
       (contained-in-box? (cg:box-top-left box1) box2)))


(defun adjust-box-on-position (box1 pos1 left-dist top-dist)
  "Takes a CG box and a CG position and returns the box that would
    put box1 around pos1 with the distance to left edge specified by
    left-dist and the distance to top edge specified by top-dist"
  (let ((new-top (- (cg:position-y pos1) top-dist))
        (new-left (- (cg:position-x pos1) left-dist)))
    (cg:make-box-relative new-left new-top (cg:width box1)
                          (cg:height box1))))

 

(defun center-box-on-position (box1 pos1)
  "Takes a CG box and a CG position and returns the box that would
    center box1 on pos1"
  (let* ((b-width (cg:width box1))
         (b-height (cg:height box1))
         (new-top (max 0 (- (cg:position-y pos1) (ceiling (/ b-height 2)))))
         (new-left (max 0 (- (cg:position-x pos1) (ceiling (/ b-width 2))))))
    (cg:make-box-relative new-left new-top (cg:width box1) (cg:height box1))))
        
  
(defun center-box-on-position-horizontally (box1 pos1)
  "Takes a CG box and a CG position and returns the box that would
    center box1 on pos1 horizontally"
  (let* ((b-width (cg:width box1))
         (b-height (cg:height box1))
         (new-top (cg:top box1))
         (new-left (max 0 (- (cg:position-x pos1) (ceiling (/ b-width 2))))))
    (cg:make-box-relative new-left new-top (cg:width box1) (cg:height box1))))

(defun center-box-on-position-vertically (box1 pos1)
  "Takes a CG box and a CG position and returns the box that would
    center box1 on pos1 vertically"
  (let* ((b-width (cg:width box1))
         (b-height (cg:height box1))
         (new-top (max 0 (- (cg:position-y pos1) (ceiling (/ b-height 2)))))
         (new-left (cg:left box1)))
    (cg:make-box-relative new-left new-top (cg:width box1) (cg:height box1))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End of Code