home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SAMPLES / MAKESOLV.S < prev    next >
Encoding:
Text File  |  1993-11-11  |  2.0 KB  |  54 lines
  1. ;* makesolv.s
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme Demo code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*           Problem solver using a generative grammar        *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Marc Vuilleumier           Date: 1993            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21. ; Goal   : generating any non-zero number from a set of numbers and operators
  22. ; Sample : Using +, -, *, / and the number 4
  23. ;       1 = 4/4
  24. ;       2 = (4+4)/4
  25. ;       etc...
  26. ;
  27. ; Usage : (define {solver} (make-solver {list of items} {list of operators}))
  28. ;       ...where each item is ({number} . {representation})
  29. ;
  30. ; Demo  : [1] (define my-solver (make-solver '((4 . 4)) (list + - * /))
  31. ;         ===> MY-SOLVER
  32. ;      [2] (my-solver 1)
  33. ;      ===> (<Procedure /> 4 4)
  34.  
  35. (define (make-solver items operators . yet)
  36.   (named-lambda (find wanted)
  37.     (set! yet
  38.       (if (car yet) 
  39.       (list #f (cadr yet) (cadddr yet) (caddr yet))
  40.       (if (cdadr yet) 
  41.           (list #t (cdadr yet) (cadddr yet) (caddr yet))
  42.           (if (not (eq? (car (cadddr yet)) (car (caddr yet))))
  43.           (list #t operators (cadddr yet) (cdaddr yet))
  44.           (if (cdr (cadddr yet))
  45.               (list #t operators (cdr (cadddr yet)) items)
  46.               (if (null? yet)
  47.               (list #t operators items items)
  48.               (error "Sorry, no solution...")))))))
  49.     (or (cdr (assoc wanted items))
  50.     (let ((res (apply (caadr yet) (map caar (cddr yet)))))
  51.       (if (not (or (zero? res) (assoc res items)))
  52.           (append! items `((,res . (,(caadr yet) ,@(map cdar (cddr yet)))))))
  53.       (find wanted)))))
  54.