; hw6.lisp
; CS 381 homework 6
; Jacob Lundberg

;;
;; Problem One
;;

; TWEAK list1 to a length of count by adding
; or removing items to/from its direc side.
; EX: > (TWEAK 'LEFT 8 '(1 2 3) 0)
;     (0 0 0 0 0 1 2 3)
;     > (TWEAK 'RIGHT 4 '(1 2 3 4 5) 1)
;     (1 2 3 4)
(defun TWEAK (direc count list1 &rest items)
  (cond ((= (length list1) count) list1)
        ((> (length list1) count) (cond
          ; crop the list, on the direc side, to count items
          ((equal direc 'LEFT)  (nthcdr  (- (length list1) count) list1))
          ((equal direc 'RIGHT) (butlast list1 (- (length list1) count)))
          ))
        ; pad the list, on the direc side, to count items
        ((equal direc 'LEFT)
          (TWEAK direc count (append items list1) (car items)))
        ((equal direc 'RIGHT)
          (TWEAK direc count (append list1 items) (car items)))
  )
)

; DEC-TO-BIN converts a positive decimal integer to a binary list.
; Numbers that aren't positive integers will become positive intsegers...
(defun DEC-TO-BIN (int1)
  (cond ; drop the sign
        ((< int1 0) (DEC-TO-BIN (abs int1)))
        ; drop the fractional part
        ((not (integerp int1)) (DEC-TO-BIN (truncate int1)))
        ; terminate case, cons nil to end of list
        ((zerop int1) nil)
        ; binary one when we have a remainder
        ((> (mod int1 2) 0) (append (DEC-TO-BIN (/ int1 2)) '(1)))
        ; binary zero when we don't
        (T                  (append (DEC-TO-BIN (/ int1 2)) '(0)))
  )
)

; FRAC-TO-BIN converts decimal number between 0 and 1 to a binary list.
; There will always result exactly maxdig binary digits.
; NOTE that this function rounds the last binary digit.
(defun FRAC-TO-BIN (num1 maxdig)
  (cond ; make sure we don't lock if passed a bad maxdig
        ((<= maxdig 0) nil)
        ; drop the sign
        ((< num1 0) (FRAC-TO-BIN (abs num1) maxdig))
        ; we've hit our stopping point; round the last digit
        ((equal maxdig 1) (cond ((> (* num1 2) 1) '(0))
                                ((> (* num1 4) 1) '(1))
                                (T                '(0))))
        ; binary 1 is when we have spillover
        ((>= (* num1 2) 1)
           (append '(1) (FRAC-TO-BIN (- (* num1 2) 1) (- maxdig 1))))
        ; binary zero is when we don't
        (T (append '(0) (FRAC-TO-BIN (* num1 2)       (- maxdig 1))))
  )
)

; COUNT-ZEROS counts the number of zeros on the direc side of list1.
(defun COUNT-ZEROS (direc list1)
  (cond ; can't count nothing
        ((null list1) 0)
        ; count left zeros
        ((and (equal direc 'LEFT) (equal (first list1) 0))
          (+ (COUNT-ZEROS 'LEFT (cdr list1)) 1))
        ; count right zeros
        ((and (equal direc 'RIGHT) (equal (last list1) '(0)))
          (+ (COUNT-ZEROS 'RIGHT (butlast list1 1)) 1))
        ; halting case
        (T 0)
  )
)

; STORE-INT implements STORE for the integer case.
;   sign exponent fraction
;   s    eeeeeeee fffffffffffffffffffffff
(defun STORE-INT (int1)
  (append ; sign
          (if (< int1 0) '(1) '(0))
          ; exponent
          (TWEAK 'LEFT 8 (DEC-TO-BIN (COUNT-ZEROS 'RIGHT (DEC-TO-BIN int1))) 0)
          ; fraction
          ; this next item is mostly a right-shifter
          (TWEAK 'LEFT 23 (butlast (DEC-TO-BIN int1)
                                  (COUNT-ZEROS 'RIGHT (DEC-TO-BIN int1))) 0)
  ) ; close append
)

; STORE-CHAR implements STORE for the char case.
;   ascii
;   bbbbbbbb
(defun STORE-CHAR (char1)
  ; translate to a left zero padded binary list of length 8
  (TWEAK 'LEFT 8 (DEC-TO-BIN (char-code char1)) 0)
)

; STORE-NUMBER implements a more realistic store for floating point numbers.
; Integers -16777216 through 16777216 accurately represented.
; Sadly, no twos complement; we use sign-magnitude instead.
; The result will be computed to all places shown.
; The lead bit of the mantissa is implied.
; The mantissa is rounded, not chopped.
; The exponent is signed.
;   sign exponent mantissa
;   s    seeeeeee mmmmmmmmmmmmmmmmmmmmmmm
(defun STORE-NUMBER (num1)
  (if (< (abs num1) 1)
      ; exponent will be negative
      (append ; sign of number
              (if (< num1 0) '(1) '(0))
              ; negative exponent
              '(1)
              ; rest of exponent
              (TWEAK 'LEFT 7 (DEC-TO-BIN
                (COUNT-ZEROS 'LEFT (FRAC-TO-BIN num1 255))) 0)
              ; mantissa, 7 bit exponent gives us up to 255 leading zeros
              (nthcdr (+ 1 (COUNT-ZEROS 'LEFT (FRAC-TO-BIN num1 255)))
                (FRAC-TO-BIN num1 (+ 24 (COUNT-ZEROS 'LEFT
                  (FRAC-TO-BIN num1 255)))))
      )
      ; exponent will be positive
      (append ; sign of number
              (if (< num1 0) '(1) '(0))
              ; positive exponent
              '(0)
              ; rest of exponent
              (TWEAK 'LEFT 7 (DEC-TO-BIN
                (length (DEC-TO-BIN num1))) 0)
              ; integer portion of mantissa
              (cdr (DEC-TO-BIN num1))
              ; fractional portion of mantissa
              (FRAC-TO-BIN (mod (abs num1) 1)
                (- 24 (length (DEC-TO-BIN num1))))
      )
  )
)

; STORE-CHAR-LIST implements STORE for a list of chars.
; when inlining no character count is issued
;   (optional character count) char1    char2    char3    ...
;   ccc                        bbbbbbbb bbbbbbbb bbbbbbbb ...
(defun STORE-CHAR-LIST (list1 &optional (inline nil))
  (cond ((null inline) (append (TWEAK 'LEFT 3 (DEC-TO-BIN (length list1)) 0)
                               (STORE-CHAR-LIST list1 T)))
        ((null list1) nil)
        (T (append (STORE-CHAR (car list1)) (STORE-CHAR-LIST (cdr list1) T)))
  )
)

; STORE-STRING implements STORE for the string case.
; Mostly just by passing off to STORE-CHAR-LIST.
(defun STORE-STRING (str1)
  ; change the string to a list of chars and pass it on
  (STORE-CHAR-LIST (coerce str1 'LIST))
)

; STORE writes the value of val1 into a list as per homework six.
; I just couldn't resist, so there are two cases implemented
; here that were not in the problem space...  Sorry.  ;-)
; You can force float eval by passing in floatme as T.
(defun STORE (val1 &optional (floatme nil))
  (cond ; STORE an integer
        ((and (integerp val1) (not floatme)) (STORE-INT val1))
        ; STORE a character
        ((characterp val1)                   (STORE-CHAR val1))
        ; STORE a number
        ((numberp val1)                      (STORE-NUMBER val1))
        ; STORE a string
        ((stringp val1)                      (STORE-STRING val1))
        ; not a value we know how to STORE
        (T                                   nil)
  )
)

;;
;; Problem Two
;;

; BIN-TO-DEC converts a positive binary bitmap to a decimal.
(defun BIN-TO-DEC (map1 &optional (place 0))
  (cond ; halt when we run out of digits
        ((null map1) 0)
        ; compute the value
        (T (+ (* (expt 2 place) (car (last map1))) ; current binary digit
              (BIN-TO-DEC (butlast map1) (+ place 1)))) ; other digits
  )
)

; BIN-TO-FRAC converts a positive binary bitmap to a decimal number (0,1).
(defun BIN-TO-FRAC (map1 &optional (place -1))
  (cond ; halt when we run out of digits
        ((null map1) 0)
        ; compute the value
        (T (+ (* (expt 2 place) (car map1)) ; current binary digit
              (BIN-TO-FRAC (cdr map1) (- place 1)))) ; other digits
  )
)

; RETRIEVE-INT performs a RETRIEVE on an integer.
; The expected bitmap size is 32.
(defun RETRIEVE-INT (map1)
  (cond ; chop or pad to 32 bits
        ((not (equal (length map1) 32))
          (RETRIEVE-INT (TWEAK 'RIGHT 32 map1 1)))
        ; ready to convert
        (T (* (if (equal (car map1) 0) 1 -1)
              (BIN-TO-DEC (TWEAK 'RIGHT (+ (BIN-TO-DEC
                (butlast (cdr map1) 23)) 23) (nthcdr 9 map1) 0))
        )  )
  )
)

; RETRIEVE-CHAR performs a RETRIEVE on a character.
; The expected bitmap size is 8.
(defun RETRIEVE-CHAR (map1)
  (cond ; chop or pad to 8 bits
        ((not (equal (length map1) 8))
          (RETRIEVE-CHAR (TWEAK 'RIGHT 8 map1 1)))
        (T (character (BIN-TO-DEC map1)))
  )
)

; BIN-TO-NUMBER turns a positive binary bitmap into a number.
; It is expecting that exp1 be in decimal.
; It wants signs expressed as {-1,1} too.
(defun BIN-TO-NUMBER (map1 sgn1 exp1 esgn)
  (if (< esgn 0)
      ; negative exponent
      (* sgn1 (BIN-TO-FRAC (TWEAK 'LEFT (+ (length map1) exp1) map1 0)))
      ; positive exponent (integral part and fractional part)
      (* sgn1 (+ (BIN-TO-DEC (TWEAK 'RIGHT exp1 map1 0))
                 (BIN-TO-FRAC (nthcdr exp1 map1))
      )       )
  )
)

; RETRIEVE-NUMBER performs RETRIEVE on a fp number as STOREd above.
; The expected bitmap size is 32.
(defun RETRIEVE-NUMBER (map1)
  (cond ; chop or pad to 32 bits
        ((not (equal (length map1) 32))
          (RETRIEVE-NUMBER (TWEAK 'RIGHT 32 map1 1)))
        ; convert to a number via BIN-TO-NUMBER
        (T (BIN-TO-NUMBER                             ; args:
          (cons 1 (nthcdr 9 map1))                    ; map1
          (if (equal (car map1) 0) 1 -1)              ; sgn1
          (BIN-TO-DEC (TWEAK 'RIGHT 7 (cddr map1) 1)) ; exp1
          (if (equal (cadr map1) 0) 1 -1)             ; esgn
        ))
  )
)

; RETRIEVE-CHAR-LIST performs a RETRIEVE on a list of chars.
; The expected bitmap size is defined by the first three bits.
(defun RETRIEVE-CHAR-LIST (map1 &optional (remain nil))
  (cond ; correct the number of chars expected
        ((null remain) (RETRIEVE-CHAR-LIST (nthcdr 3 map1)
          (BIN-TO-DEC (TWEAK 'RIGHT 3 map1 1))))
        ; cause for termination
        ((<= remain 0) nil)
        ; pad this binary sequence if needed (so nthcdr won't fail)
        ((< (length map1) 8) (RETRIEVE-CHAR-LIST
          (TWEAK 'RIGHT 8 map1 1) remain))
        ; construct the list
        (T (cons (character (BIN-TO-DEC (TWEAK 'RIGHT 8 map1 1)))
          (RETRIEVE-CHAR-LIST (nthcdr 8 map1) (- remain 1))))
  )
)


; RETRIEVE-STRING performs RETRIEVE on a string.
; We just pass off to RETRIEVE-CHAR-LIST here.
(defun RETRIEVE-STRING (map1)
  (coerce (RETRIEVE-CHAR-LIST map1) 'STRING)
)

; RETRIEVE a binary sequence generated by STORE to its display form.
(defun RETRIEVE (bitmap maptype)
  (cond ; RETRIEVE an integer
        ((equal maptype 'NUMBER) (RETRIEVE-INT bitmap))
        ; RETRIEVE a character
        ((equal maptype 'CHAR)   (RETRIEVE-CHAR bitmap))
        ; RETRIEVE a number
        ((equal maptype 'FLOAT)  (RETRIEVE-NUMBER bitmap))
        ; RETRIEVE a string
        ((equal maptype 'STRING) (RETRIEVE-STRING bitmap))
        ; not a type we know how to RETRIEVE
        (T nil)
  )
)

;;
;; Problem Three
;;

; Just a hardwired answer-spitter.
(defun PROBLEM3 ()
  '(RUNTIME-ERROR RUNTIME-ERROR NO-ERROR RUNTIME-ERROR COMPILETIME-ERROR)
)

;;
;; Problem Four
;;

; TYPE-EQUIV? checks for name or structure type equivalence in two lists.
; Equivalence is considered failed if the list lengths differ.
(defun TYPE-EQUIV? (list1 list2 &optional (atname T))
  (cond ; check for list2 end before list1
        ((and list1 (null list2)) nil)
        ; check for list1 end before list2
        ((and (null list1) list2) nil)
        ; check for type equivalence; (nil) == (nil) and we're done
        ((and (null list1) (null list2)) "Structure")
        ; nil is an annoying special case; nil != nil
        ((and (null (car list1)) (null (car list2)))
          (TYPE-EQUIV? (cdr list1) (cdr list2) nil))
        ; check for name equivalence
        ((and atname (equal (car list1) (car list2))) "Name")
        ; fall through if name equivalence fails
        (atname (TYPE-EQUIV? (cdr list1) (cdr list2) nil))
        ; scan each pair for type equivalence
        ((equalp (type-of (car list1)) (type-of (car list2)))
          (TYPE-EQUIV? (cdr list1) (cdr list2) nil))
        ; bummer, not equivalent
        (T nil)
  )
)