
;; -*-scheme-*-
(format #t "===============================================================~%")
(format #t "==================== Testing ==================================~%")
(format #t "===============================================================~%")

;; makes tests fail.
;; (turn-on-debugging)

; (define greg-data-dir "greg-data")

; cut and paste this:
; (define imol-rnase (greg-pdb "tutorial-modern.pdb"))

(define greg-data-dir
  (let ((d (getenv "COOT_TEST_DATA_DIR")))
    (if d
	d
	(append-dir-dir (append-dir-dir (getenv "HOME")
					"data")
			"greg-data"))))

(define (greg-pdb file-name)
  (read-pdb (append-dir-file greg-data-dir file-name)))

(define rnase-pdb (append-dir-file greg-data-dir "tutorial-modern.pdb"))
(define rnase-mtz (append-dir-file greg-data-dir "rnasa-1.8-all_refmac1.mtz"))

; How fast does the graphics rotate things (relative to kalypso)
(define rotate-speed 1)

(let ((host (getenv "HOST")))
  (if (string? host)
      (cond
       ((string=? host "penelope")
	(set! rotate-speed 0.1))
       ((string=? host "laertes")
	(set! rotate-speed 0.1))
       ((string=? host "cycle")
	(set! rotate-speed 0.1)))))

(define (rotate-n-frames n)
  (inexact->exact (round (* n rotate-speed))))

(define (test-list ls)
  (let loop ((ls ls))
    (cond
     ((null? ls) #t)
     ((equal? (car (car ls)) (cdr (car ls)))
      (loop (cdr ls)))
     (else 
      (format #t "fail match real: ~s  expected: ~s~%"
	      (car (car ls)) (cdr (car ls)))
      #f))))

(define (chains-in-order? ls)
  (cond
   ((null? ls) #t)
   ((= (length ls) 1) #t)
   ((string>? (car ls) (car (cdr ls))) #f)
   (else
    (chains-in-order? (cdr ls)))))


(define (bond-length pos-1 pos-2)
  (define (square x)
    (* x x))
  
  (sqrt (apply + (map square (map - pos-1 pos-2)))))

(define pos-difference bond-length)


(define (all-true? ls)
  (cond
   ((null? ls) #t)
   ((eq? #t (car ls))
    (all-true? (cdr ls)))
   (else 
    #f)))
  

(define (bond-length-from-atoms atom-1 atom-2)
  (if (not (list? atom-1))
      (begin
	(format #t "   WARNING:: bond-length-from-atoms: atom-1 not a list: ~s~%" atom-1)
	#f)
      (if (not (list? atom-2))
	  (begin
	    (format #t "   WARNING:: bond-length-from-atoms: atom-2 not a list: ~s~%" atom-2)
	    #f)
	  (bond-length (list-ref atom-1 2)
		       (list-ref atom-2 2)))))

(define (bond-length-within-tolerance? atom-1 atom-2 ideal-length tolerance)

  (if (not atom-1)
      (throw 'missing-atom-1)
      (if (not atom-2)
	  (throw 'missing-atom-2)
	  (let ((b (bond-length-from-atoms atom-1 atom-2)))
	    (format #t "bond-length-within-tolerance? bond-length ~s with target ~s and tolerance ~s for atoms\n   ~s and\n   ~s~%~!"
		    b ideal-length tolerance atom-1 atom-2)
	    (< (abs (- b ideal-length)) tolerance)))))


(define (shelx-waters-all-good-occ? imol-insulin-res)

  (let ((chain-id (water-chain imol-insulin-res)))
    (let ((n-residues (chain-n-residues chain-id imol-insulin-res)))
      (let ((serial-number (- n-residues 1)))
	(let ((res-name (resname-from-serial-number imol-insulin-res chain-id serial-number))
	      (res-no   (seqnum-from-serial-number  imol-insulin-res chain-id serial-number))
	      (ins-code (insertion-code-from-serial-number imol-insulin-res chain-id serial-number)))
	  
	  (if (string=? res-name "HOH")
	      (let ((atom-list (residue-info imol-insulin-res chain-id res-no ins-code)))
		(for-each 
		 (lambda (atom)
		   (let ((occ (car (car (cdr atom)))))
		     (if (not (close-float? occ 11.0))
			 (begin
			   (format #t "  bad occupancy in SHELXL molecule ~s~%" atom)
			   (throw 'fail)))))
		 atom-list)))))
      #t)))

;; return restraints without the given bond restraints
(define (strip-bond-from-restraints atom-pair restraints)

  (define (strip-bond bond-restraints)
    (cond
     ((null? bond-restraints) '())
     ((and (string=? (car (car bond-restraints)) (car atom-pair))
	   (string=? (car (cdr (car bond-restraints))) (car (cdr atom-pair))))
      (cdr bond-restraints))
     (else 
      (cons (car bond-restraints)
	    (strip-bond (cdr bond-restraints))))))


  ;; main line of strip-bond-restraints
  (cond 
   ((not restraints) #f)
   ((null? restraints) '())
   ((string=? "_chem_comp_bond" (car (car restraints)))
    ; (format #t "strip-bond on::::: ~s ~%" (car (cdr (car restraints))))
    (cons 
     (cons (car (car restraints)) (strip-bond (cdr (car restraints))))
     (cdr restraints)))
   (else 
    (cons (car restraints) 
	  (strip-bond-from-restraints atom-pair (cdr restraints))))))

;; move to begin.grg.
;;
;; are the attributes of atom-1 the same as atom-2? (given we test for
;; close-float?)
;;
(define (atoms-match? atom-1 atom-2)
  (cond
   ((null? atom-1) #t)
   ((list? (car atom-1))
    (if (atoms-match? (car atom-1) (car atom-2))
	(atoms-match? (cdr atom-1) (cdr atom-2))
	#f))
   ((string? (car atom-1))
    (string=? (car atom-1) (car atom-2)))
   ((exact? (car atom-1))
    (close-float? (car atom-1) (car atom-2)))
   ((number? (car atom-1))
    (= (car atom-1) (car atom-2)))
   ((boolean? atom-1)
    (eq? (car atom-1) (car atom-2)))
   (else 
    #f)))


(define accumulate
  (lambda (op initial sequence)

    (if (null? sequence)
        initial
        (op (car sequence)
            (accumulate op initial (cdr sequence))))))


;;; transform
;;; Just a (eg 3x3) (no vector) matrix
;;; The matrix does not have to be symmetric.
;;;
(define transpose-mat
  (lambda (mat)

    (if (null? (car mat))
	'()
	(cons (accumulate   cons '() (map car mat))
              (transpose-mat (map cdr mat))))))


;; What is the distance atom-1 to atom-2? 
;; return #f on not able to calculate
(define (atom-distance atom-1 atom-2)
  (define (square x) (* x x))
  (sqrt (apply + (map square (map - (car (cdr (cdr atom-1))) (car (cdr (cdr atom-2))))))))

;; A term atom is (currently) characterized by an atom name of "".
;;
(define (has-term-atom? atom-list)

  (cond 
   ((null? atom-list) #f)
   ((string=? "" (car (car (car atom-list)))) #t)
   (else 
    (has-term-atom? (cdr atom-list)))))
    

;; a function from 04-cootaneering:
;;
;; note that things could go wrong if there is a mising EOL (not tested)
;; 
(define (file->string rnase-pir)
  (call-with-input-file rnase-pir
    (lambda (port)
      (let loop  ((lines '())
		  (line (read-line port)))
	(cond
	 ((eof-object? line) 
	  (string-append-with-string (reverse lines) "\n"))
	 (else
	  (loop (cons line lines) (read-line port))))))))


(define (atoms-have-correct-seg-id? atoms seg-id)
  
  (let loop ((atoms atoms))
    (cond
     ((null? atoms) #t)
     ((let ((atom-seg-id (list-ref (list-ref (car atoms) 1) 3)))
	(not (string=? atom-seg-id seg-id)))
      #f)
     (else 
      (atoms-have-correct-seg-id? (cdr atoms) seg-id)))))


;; return the residue name given a 4 element spec
;;
(define (residue-name-from-spec imol spec)

  (if (= (length spec) 4)
      (apply residue-name imol (cdr spec))
      (apply residue-name imol spec)))


;; return residue specs of all residues that are type residue-type
;; 
(define (get-residues-in-molecule-of-type imol residue-type)

  (filter (lambda (spec)
	    (let ((rn (residue-name-from-spec imol spec)))
	      (if (not (string? rn))
		  #f
		  (if (not (string=? rn residue-type))
		      #f
		      rn))))
	  (fit-protein-make-specs imol 'all-chains)))


;; This takes 4 member specs, return #t or #f
;; 
(define (specs-match? spec-1 spec-2)

  ;; first test if specs are of length 3.
  ;; 
  (if (not (= (length spec-1) 4))
      #f 
      (if (not (= (length spec-2) 4))
	  #f
	  (let ((chain-id-1 (list-ref spec-1 1))
		(chain-id-2 (list-ref spec-2 1))
		(res-no-1   (list-ref spec-1 2))
		(res-no-2   (list-ref spec-2 2))
		(ins-code-1 (list-ref spec-1 3))
		(ins-code-2 (list-ref spec-2 3)))

	    (if (not (string? chain-id-1))
		#f
		(if (not (string? chain-id-2))
		    #f
		    (if (not (string=? chain-id-1 chain-id-2))
			#f
			(if (not (number? res-no-1))
			    #f
			    (if (not (number? res-no-2))
				#f
				(if (not (= res-no-1 res-no-2))
				    #f
				    (if (not (string? ins-code-1))
					#f
					(if (not (string? ins-code-2))
					    #f
					    (if (not (string=? ins-code-1 ins-code-2))
						#f
						#t)))))))))))))
					      

		  

(set-console-display-commands-hilights 0 0 0)
;; in fact, shut up altogether.
(set-console-display-commands-state 0)
