;;
;; Copyright (c) 2006, John P. T. Moore
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without 
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice, 
;;    this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice, 
;;    this list of conditions and the following disclaimer in the documentation 
;;    and/or other materials provided with the distribution.
;;
;; 3. Neither the name of the author nor the names of its contributors may be 
;;    used to endorse or promote products derived from this software 
;;    without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 
;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 
;; ARISING IN ANforeign function functionsY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 
;; POSSIBILITY OF SUCH DAMAGE.
;;


;; foreign functions
(define c-encode-boolean
  (foreign-lambda void "encodeBoolean" (c-pointer packed-encode) bool))

(define c-encode-semi-constrained-string
    (foreign-lambda void "encodeSemiConstrainedString" (c-pointer packed-encode) c-string))

(define c-encode-constrained-string
    (foreign-lambda void "encodeConstrainedString" (c-pointer packed-encode) c-string integer integer))

(define c-encode-fixed-length-string
    (foreign-lambda void "encodeFixedLengthString" (c-pointer packed-encode) c-string integer))
		
(define c-encode-unconstrained-integer
    (foreign-lambda void "encodeUnconstrainedInteger" (c-pointer packed-encode) integer))

(define c-encode-unsigned-constrained-integer
    (foreign-lambda void "encodeUnsignedConstrainedInteger" (c-pointer packed-encode) unsigned-integer unsigned-integer unsigned-integer))

(define c-encode-signed-constrained-integer
    (foreign-lambda void "encodeSignedConstrainedInteger" (c-pointer packed-encode) integer integer integer))

(define c-encode-signed-semi-constrained-integer
    (foreign-lambda void "encodeSignedSemiConstrainedInteger" (c-pointer packed-encode) integer integer))

(define c-encode-unsigned-semi-constrained-integer
    (foreign-lambda void "encodeUnsignedSemiConstrainedInteger" (c-pointer packed-encode) unsigned-integer unsigned-integer))

(define c-encode-constrained-hex-string
  (foreign-lambda void "encodeConstrainedHexString" (c-pointer packed-encode) c-string integer integer))

(define c-encode-fixed-length-hex-string
  (foreign-lambda void "encodeFixedLengthHexString" (c-pointer packed-encode) c-string integer))

(define c-encode-semi-constrained-hex-string
  (foreign-lambda void "encodeSemiConstrainedHexString" (c-pointer packed-encode) c-string))

(define c-encode-constrained-numeric-string
  (foreign-lambda void "encodeConstrainedNumericString" (c-pointer packed-encode) c-string integer integer))

(define c-encode-fixed-length-numeric-string
  (foreign-lambda void "encodeFixedLengthNumericString" (c-pointer packed-encode) c-string integer))

(define c-encode-semi-constrained-numeric-string
  (foreign-lambda void "encodeSemiConstrainedNumericString" (c-pointer packed-encode) c-string))

(define c-encode-constrained-bit-string
  (foreign-lambda void "encodeConstrainedBitString" (c-pointer packed-encode) c-string integer integer))

(define c-encode-fixed-length-bit-string
  (foreign-lambda void "encodeFixedLengthBitString" (c-pointer packed-encode) c-string integer))

(define c-encode-semi-constrained-bit-string
  (foreign-lambda void "encodeSemiConstrainedBitString" (c-pointer packed-encode) c-string))

(define c-encode-constrained-octet-string
  (foreign-lambda void "encodeConstrainedOctetString" (c-pointer packed-encode) c-string integer integer))

(define c-encode-fixed-length-octet-string
  (foreign-lambda void "encodeFixedLengthOctetString" (c-pointer packed-encode) c-string integer))

(define c-encode-semi-constrained-octet-string
  (foreign-lambda void "encodeSemiConstrainedOctetString" (c-pointer packed-encode) c-string))

(define c-encode-enumerated
  (foreign-lambda void "encodeEnumerated" (c-pointer packed-encode) unsigned-integer unsigned-integer))

(define c-encode-set-bitmap
    (foreign-lambda void "encodeSetBitmap" c-pointer c-string integer))
	
(define c-encode-choice-index
    (foreign-lambda void "encodeChoiceIndex" c-pointer unsigned-integer unsigned-integer))	
	
(define c-encode-sequence-of-length
    (foreign-lambda void "encodeSequenceOfLength" c-pointer integer))


;;; end of foreign interface

(define encode:datatype cadar)
(define encode:value cadr)
(define encode:constraint caddar) 

(define (po:encode t p)
  
  (define (encode-simple-type)
    
    (define (encode-integer)
      (let* ( (range (encode:constraint t)) (type (po:check-integer range)) )
        (case type
          ('unconstrained
           (c-encode-unconstrained-integer p (encode:value t)))
          ('unsigned-semi-constrained
           (c-encode-unsigned-semi-constrained-integer p (encode:value t) (constraints:lb range)))
          ('unsigned-constrained
           (c-encode-unsigned-constrained-integer p (encode:value t) (constraints:lb range) (constraints:ub range)))
          ('signed-semi-constrained
           (c-encode-signed-semi-constrained-integer p (encode:value t) (constraints:lb range)))
          ('signed-constrained
           (c-encode-signed-constrained-integer p (encode:value t) (constraints:lb range) (constraints:ub range))))))
    
    (define (encode-string)
      (let* ( (size (encode:constraint t)) (type (po:check-string size)) )
        (case type
          ('semi-constrained
           (c-encode-semi-constrained-string p (encode:value t)))
          ('fixed-length
           (c-encode-fixed-length-string p (encode:value t) (constraints:lb size)))
          ('constrained
           (let ((lbv (constraints:lb size)))
             (c-encode-constrained-string p (encode:value t) (if (eq? lbv 'min) 0 lbv) (constraints:ub size)))))))
    
    (define (encode-octet-string)
      (let* ( (size (encode:constraint t)) (type (po:check-string size)) )
        (case type
          ('semi-constrained
           (c-encode-semi-constrained-octet-string p (encode:value t)))
          ('fixed-length
           (c-encode-fixed-length-octet-string p (encode:value t) (constraints:lb size)))
          ('constrained
           (let ((lbv (constraints:lb size)))
             (c-encode-constrained-octet-string p (encode:value t) (if (eq? lbv 'min) 0 lbv) (constraints:ub size)))))))
    
    (define (encode-hex-string)
      (let* ( (size (encode:constraint t)) (type (po:check-string size)) )
        (case type
          ('semi-constrained
           (c-encode-semi-constrained-hex-string p (encode:value t)))
          ('fixed-length
           (c-encode-fixed-length-hex-string p (encode:value t) (constraints:lb size)))
          ('constrained
           (let ((lbv (constraints:lb size)))
             (c-encode-constrained-hex-string p (encode:value t) (if (eq? lbv 'min) 0 lbv) (constraints:ub size)))))))    

    (define (encode-numeric-string)
      (let* ( (size (encode:constraint t)) (type (po:check-string size)) )
        (case type
          ('semi-constrained
           (c-encode-semi-constrained-numeric-string p (encode:value t)))
          ('fixed-length
           (c-encode-fixed-length-numeric-string p (encode:value t) (constraints:lb size)))
          ('constrained
           (let ((lbv (constraints:lb size)))
             (c-encode-constrained-numeric-string p (encode:value t) (if (eq? lbv 'min) 0 lbv) (constraints:ub size))))))) 

    
    (define (encode-bit-string)
        (let* ( (size (encode:constraint t)) (type (po:check-string size)) )
          (case type
            ('semi-constrained
             (c-encode-semi-constrained-bit-string p (encode:value t)))
            ('fixed-length
             (c-encode-fixed-length-bit-string p (encode:value t) (constraints:lb size)))
            ('constrained
             (let ((lbv (constraints:lb size)))
               (c-encode-constrained-bit-string p (encode:value t) (if (eq? lbv 'min) 0 lbv) (constraints:ub size)))))))    
      
      
      (define (encode-boolean)
        (c-encode-boolean p (encode:value t)))
      
      (define (encode-enumerated)
        (let* ((enum (caddar t))
               (enum-len (length enum))
               (index (list-index (lambda (x) (eq? x (encode:value t))) enum)))
          (if index
              (c-encode-enumerated p index enum-len)
              (error "enumeration failed" (encode:value t) enum))))

      (define (encode-null)
        'do-nothing)
      
      (let ((type (encode:datatype t)))
        (case type
          ('integer
           (encode-integer))
          ('boolean
           (encode-boolean))
          ('octet-string
           (encode-octet-string))
          ('hex-string
           (encode-hex-string))
          ('numeric-string
           (encode-numeric-string))
          ('bit-string
           (encode-bit-string))
          ('enumerated
           (encode-enumerated))
          ('null
           (encode-null))
          ('string
           (encode-string)))))
  
  
  (define (encode-complex-type)
    (define (recur-sequence seq)
      (cond ((null? seq) 'done-sequence)
            (else
             (po:encode (car seq) p)
             (recur-sequence (cdr seq)))))
    
    (define (recur-sequence-of seq)
      (cond ((null? seq) 'done-sequence-of)
            (else
             (recur-sequence (car seq))
             (recur-sequence-of (cdr seq)))))     
    (define (encode-sequence)
      (recur-sequence (cdr t)))
    (define (encode-sequence-of)
      (c-encode-sequence-of-length p (caddar t))
      (recur-sequence-of (cdr t)))  
    
    (define (encode-set)
      (define (recur-set bit order)
        (cond ((null? order) 'done-set)
              (else
               (cond ((eq? (first-string bit) #\1)
                      (let ((v (find (lambda (x) (eq? (caar x) (car order))) (cdr t))))
                        (po:encode v p))
                      (recur-set (rest-string bit) (cdr order)))
                     (else
                      (recur-set (rest-string bit) (cdr order)))))))
      
      ;; obtain the ordering list
      (let* ((order-by (cdr (caddr (car t))))
             (bitmap  (cadddr (car t))))
        (c-encode-set-bitmap p bitmap (string-length bitmap))
        (recur-set bitmap order-by)))      
    
    (define (encode-choice)
      ;; range of choices in spec (range 1 n)
      (c-encode-choice-index p (car (cdddar t)) (caddr (caddar t)))
      (po:encode (cadr t) p))

    ;; end of definitions

    (let ((type (encode:datatype t)))
      (case type
        ('sequence
          (encode-sequence))
        ('sequence-of
         (encode-sequence-of))
        ('set
         (encode-set))
        ('choice
         (encode-choice)))))
  
  (if (memq (encode:datatype t) '(sequence choice sequence-of set))
      (encode-complex-type)
      (encode-simple-type)))