(in-package :cl-user)

(defstruct (db)
  (intro-bytes)
  (entries)
  )

(defstruct (entry)
  (name)
  (birthday)
  (cell)
  (phone)
  (phone2)
  (fax)
  (email)
  (company)
  (im)
  (address)
  (zip)
  (remarks)

  (header-bytes)
  (footer-bytes)
  (no))

(defconstant +field-and-lengths+
  (list 
   (list :name
         "Name       " (length "0................................................................................."))
   (list :birthday 
         "Birthday   " (length "1................................................................................."))
   (list :cell
         "Cell phone " (length "2................................................................................."))
   (list :phone
         "Telephone  " (length "3................................................................................."))
   (list :phone2
         "Telephone 2" (length "4................................................................................."))
   (list :fax
         "Fax        " (length "5................................................................................."))
   (list :email
         "Email      " (length "6................................................................................."))
   (list :company
         "Company    " (length "7........................................................................................................................................................................................................."))
   (list :im 
         "IM address " (length "8........................................................................................................................................................................................................."))
   (list :address
         "Address    " (length "9........................................................................................................................................................................................................."))
   (list :zip
         "Postal code" (length "1................................................................................."))
   (list :remarks
         "Remarks    " (length "2........................................................................................................................................................................................................."))))

(defun make-franklin-string (string)
  (loop as char in (coerce string 'list)
        collect (char-code char)
        collect 0))

(defun make-line (string)
  (list string
        (make-franklin-string string)))

(defun make-db-entry (&rest args)
  (apply #'make-entry 
         (loop as key in args by #'cddr
               as val in (cdr args) by #'cddr
               as line =  (make-line val)
               append (list key
                            #+:ignore
                            (list (first line) 
                                  (subseq (second line)
                                          0 
                                          (min (length (second line))
                                               (third (assoc key +field-and-lengths+)))))
                            (first line)))))

(defvar *db* (make-db))

(defun read-franklin (&optional include-original-bytes-p)
  (let ((intro-bytes nil))
    (with-open-file (stream "phonebook.bin" :element-type 'unsigned-byte)
      (push (princ (read-byte stream nil nil)) intro-bytes)
      (princ " ")
      (push (princ (read-byte stream nil nil)) intro-bytes)
      (princ " ")
      (push (princ (read-byte stream nil nil)) intro-bytes)
      (princ " ")
      (push (princ (read-byte stream nil nil)) intro-bytes)
      (princ " ")
      (terpri)
      
      (let ((all-entries nil)
            (count 0))
        
        (loop
          (let ((header-bytes nil)
                (footer-bytes nil)
                (all-fields-bytes nil))
            (terpri)
            (push (princ (read-byte stream nil nil)) header-bytes)
            (princ " ")
            (push (princ (read-byte stream nil nil)) header-bytes)
            (princ " ")
            (format t "~%Eintrag ~A:" (incf count))
            (loop as (key field length) in +field-and-lengths+ 
                  do
                  (let ((field-bytes nil))
                    (format t "~%~A: " field)
                    (dotimes (i (floor length 2))
                      (let ((byte (read-byte stream nil nil))
                            (byte2 (read-byte stream nil nil)))
                        (push byte field-bytes)
                        (cond (byte
                               (if (zerop byte)
                                   (princ ".")
                                 (princ (code-char byte)))
                               (push byte2 field-bytes)
                               (unless (zerop byte2)
                                 (break "surprise! non zero byte2 - thought this cannot happen?")))
                              (t 
                               (format t "~% EOF - at byte ~A~%" (* i 2))))))
                    (let* ((field-bytes (reverse field-bytes))
                           (string (coerce (loop as byte in field-bytes 
                                                    by #'cddr 
                                                    unless (zerop byte) 
                                                    collect (code-char byte))
                                              'string))
                           (field-bytes 
                            (if include-original-bytes-p
                                (list string field-bytes)
                              string)))
                      (push (list key field-bytes) all-fields-bytes))))
            (terpri)
            (push (princ (read-byte stream nil nil)) footer-bytes)
            (princ " ")
            (push (princ (read-byte stream nil nil)) footer-bytes)
            (terpri)
            (push (apply #'make-entry 
                         :no count
                         :header-bytes header-bytes 
                         :footer-bytes footer-bytes
                         (apply #'append all-fields-bytes))
                  all-entries)
            (when (equal (list nil nil) footer-bytes)
              (return))))

        (setf (db-intro-bytes *db*) (reverse intro-bytes)
              (db-entries *db*) (reverse all-entries))))))

(defun flatten (tree)
  (if (consp tree)
      (append (flatten (car tree))
              (flatten (cdr tree)))
    (when tree (list tree))))

(defun write-franklin (&optional (db *db*))
  (with-open-file (stream "phonebook-new.bin" 
                          :direction :output
                          :if-exists :supersede
                          :if-does-not-exist :create
                          :element-type 'unsigned-byte)

    (let ((count 0)
          (last (first (last (db-entries db))))
          (fill-up-to 100)
          (null-entry
           #S(ENTRY :NAME "" :BIRTHDAY "" :CELL "" :PHONE "" :PHONE2 "" :FAX "" :EMAIL "" :COMPANY "" :IM "" :ADDRESS "" :ZIP "" :REMARKS "")))

      (declare (ignorable null-entry fill-up-to))

      (dolist (byte (or (db-intro-bytes db)
                        (list (length (db-entries db)) 0 0 0 )))
        (write-byte byte stream))

      (dolist (entry (append (db-entries db)
                             #+:ignore
                             (loop as i from 1 to (- fill-up-to (length (db-entries db)))
                                   collect null-entry)))
        (incf count)
        (dolist (header-byte (or (entry-header-bytes entry)
                                 (list 0 0)))
          (write-byte header-byte stream))
        (dolist (key (list :name
                           :birthday
                           :cell
                           :phone
                           :phone2
                           :fax
                           :email
                           :company
                           :im
                           :address
                           :zip
                           :remarks))
          (let* ((n (third (assoc key +field-and-lengths+)))
                 (val (slot-value entry (intern (symbol-name key))))
                 (val (if (stringp val)
                          (zip (mapcar #'char-code (coerce val 'list)))
                        (second val)))
                 (val (subseq val
                              0 
                              (min (length val) n))))
            (dolist (byte (append val
                                  (loop as i from 1 to (- n (length val)) collect 0)))
              (write-byte byte stream))))
        (unless (eq entry last)
          (dolist (footer-byte (or (entry-footer-bytes entry)
                                   (list 0 0)))
            (write-byte footer-byte stream)))))))

(defun zip (list)
  (loop as byte in list
        collect byte
        collect 0))

(defvar *db1*
  (make-db :entries
           (sort (list
                  #S(ENTRY :NAME "Test"
                           :BIRTHDAY "1.1.2111"
                           :CELL "123456"
                           :PHONE "123456"
                           :PHONE2 "123456"
                           :FAX "123456"
                           :EMAIL "test@test.de" 
                           :COMPANY "Test Home"
                           :IM "test@im.de"
                           :ADDRESS "Musterweg 123"
                           :ZIP "12345 Musterstadt"
                           :REMARKS "OK, how are you? öäüß~!§+{}[]@"))
                 #'string< 
                 :key #'entry-name)))