;; -*-theme-d-*-

;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.

;; Expected results: translation and running OK


(define-proper-program (tests test5)


  (import (standard-library core)
	  (standard-library console-io))


  (define-param-proc my-map1 (%arg-type %result-type)
    (((proc (:procedure (%arg-type) %result-type pure))
      (arg-list (:uniform-list %arg-type)))
     (:uniform-list %result-type)
     pure)
    (if (equal? arg-list null)
	null
	(let ((arg-list1
	       (cast (:nonempty-uniform-list %arg-type) arg-list)))
	  (cons (proc (car arg-list1))
		(my-map1 proc (cdr arg-list1))))))


  (declare my-member? (:procedure (<object> (:uniform-list <object>))
				  <boolean> pure))


  (define my-member?
    (lambda (((value <object>) (lst (:uniform-list <object>)))
	     <boolean> pure)
      (if (equal? lst null)
	  #f
	  (let ((lst1 (cast (:nonempty-uniform-list <object>) lst)))
	    (or (equal? (car lst1) value)
		(my-member? value (cdr lst1)))))))


  (define-param-proc my-do-map (%arglist %result-type)
    (((proc (:procedure ((splice %arglist)) %result-type pure))
      (arg-lists (type-loop %argtype %arglist
			    (:uniform-list %argtype))))
     (:uniform-list %result-type)
     pure)
    (if (my-member? null arg-lists)
	null
	(let* ((first-members0
		(my-map1
		 (lambda (((lst (:uniform-list <object>))) <object> pure)
		   (let ((lst1
			  (cast (:nonempty-uniform-list <object>) lst)))
		     (car lst1)))
		 arg-lists))
	       (first-members (cast %arglist first-members0))
	       (new-value (apply proc first-members))
	       (tails0
		(my-map1
		 (lambda (((lst (:uniform-list <object>)))
			  (:uniform-list <object>) pure)
		   (let ((lst1
			  (cast (:nonempty-uniform-list <object>) lst)))
		     (cdr lst1)))
		 arg-lists))
	       (tails (cast (type-loop %argtype %arglist
				       (:uniform-list %argtype))
			    tails0)))
	  (cons new-value
		(my-do-map proc tails)))))


  (define-param-proc my-map (%arglist %result-type)
    (((proc (:procedure ((splice %arglist)) %result-type pure))
      (arg-lists (splice (type-loop %argtype %arglist
				    (:uniform-list %argtype)))))
     (:uniform-list %result-type)
     pure)
    (my-do-map proc arg-lists))


  (define display-list
    (lambda (((lst (:uniform-list <object>))) <none> nonpure)
      (console-display lst)
      (console-newline)))


  (define-param-proc make-my-pair (%type)
    (((a %type) (b %type)) (:pair %type %type) pure)
    (cons a b))


  (define main
    (lambda (() <integer> nonpure)
      (let ((my-list1 (list 1.0 2.0 3.0 4.0 5.0))
	    (my-list2 (list 1.1 -3.4 12.0 4.1 6.8)))
	(let ((new-list1 (my-map (param-proc-instance make-my-pair
						      <real>)
				 my-list1 my-list2))
	      (new-list2 (my-map (param-proc-dispatch make-my-pair
						      <real> <real>)
				 my-list1 my-list2)))
	  (display-list new-list1)
	  (display-list new-list2)))
      0)))
