snippets
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 

89 lines
3.2 KiB

  1. #lang curly-fn rosette
  2. (require syntax/parse/define
  3. (for-syntax racket/syntax))
  4. ;; house is represented by actual number
  5. ;; people, places, pets represented by symbolic variable
  6. (define-for-syntax *data*
  7. '((name martin ramsey sandra turner walter)
  8. (place london kansas france taipei mumbai)
  9. (pet robins tigers whales ferret poodle)))
  10. ;; create a solver and define all the symbolic variables
  11. (define-simple-macro (define-symbols/solver solver:id)
  12. ;; generate list of ids, bound to calling lexical context, with a syntax prop determining the
  13. ;; category
  14. #:with (ids ...) (for*/list ([row (in-list *data*)] [val (in-list (rest row))])
  15. (syntax-property (format-id #'solver "~a" val) 'icebreaker:cat (first row)))
  16. ;; create the symbolic define expressions
  17. #:with (defs ...) (for/list ([id (in-list (syntax-e #'(ids ...)))])
  18. #`(define-symbolic #,id integer?))
  19. ;; create initial constraints
  20. #:with (stmts ...) (let ([groups (group-by #{syntax-property % 'icebreaker:cat }
  21. (syntax-e #'(ids ...)))])
  22. (append (for*/list ([grp (in-list groups)] [id (in-list grp)])
  23. ;; all in [1, 5]
  24. #`(void (solver (<= 1 #,id 5))))
  25. (for/list ([grp (in-list groups)])
  26. ;; no two in the same category are equal
  27. #`(void (solver (mutually-exclusive #,@grp))))))
  28. (begin
  29. ;; incremental solver
  30. (define solver (solve+))
  31. defs ...
  32. stmts ...))
  33. (define-symbols/solver inc)
  34. ;; helper for defining the statements of one person (2 true, 1 lie)
  35. (define-simple-macro (define-statements solver:expr sfirst:expr ssecond:expr sthird:expr)
  36. (void
  37. (solver (or (and sfirst ssecond (not sthird))
  38. (and sfirst (not ssecond) sthird)
  39. (and (not sfirst) ssecond sthird)))))
  40. ;; helper for defining a mutually exclusive set of symbolic and concrete values
  41. (define-simple-macro (mutually-exclusive options:expr ...)
  42. #:with (stxs ...) (for/list ([combo (in-combinations (syntax-e #'(options ...)) 2)])
  43. #`(not (= #,(first combo) #,(second combo))))
  44. (and stxs ...))
  45. ;; helper for asserting that 2 houses are at a certain distance apart
  46. (define-simple-macro (at-distance v1:expr v2:expr dist:expr)
  47. (= dist (abs (- v1 v2))))
  48. ;; the rules
  49. ;; martin
  50. (define-statements inc
  51. (mutually-exclusive 1 ramsey ferret poodle kansas)
  52. (and (at-distance turner whales 4) (not (= turner whales)))
  53. (and (= walter france) (not (= walter ferret))))
  54. ;; ramsey
  55. (define-statements inc
  56. (and (at-distance martin london 4) (not (= martin london)))
  57. (and (= sandra london) (not (= sandra ferret)))
  58. (= walter (sub1 ramsey)))
  59. ;; sandra
  60. (define-statements inc
  61. (= sandra robins)
  62. (at-distance whales france 2)
  63. (= walter taipei))
  64. ;; turner
  65. (define-statements inc
  66. (not (= turner kansas))
  67. (= turner tigers)
  68. (and (= ramsey robins) (at-distance ramsey turner 3)))
  69. ;; walter
  70. (define-statements inc
  71. (mutually-exclusive walter poodle 2)
  72. (mutually-exclusive walter sandra robins mumbai taipei)
  73. (and (= turner kansas) (not (= turner 1))))
  74. (define solution (inc #t))
  75. (displayln solution)