[ch-077/jeongoon] ch-1.lsp added, ch-1.hs bug fixed.

2 files changed, 173 insertions, 10 deletions

diff --git a/challenge-077/jeongoon/common-lisp/ch-1.lsp b/challenge-077/jeongoon/common-lisp/ch-1.lsp
new file mode 100644
index 0000000000..24bf85a27e
--- /dev/null
+++ b/challenge-077/jeongoon/common-lisp/ch-1.lsp
@@ -0,0 +1,156 @@
+;; translated from ch-1.pl
+
+;; fibonacci number in reverse order upto limit
+(defun rfibs (limit) ;; ignore first number 1 for challenge purpose
+  (if (= limit 1) (list 1)
+    (if (= limit 2) (list 2 1)
+      (let ((rfib (list 2 1)))
+        (loop for nf = (+ (car rfib) (cadr rfib))
+              if (<= nf limit) do (setq rfib (cons nf rfib))
+              else do (return))
+        rfib))))
+
+;;(format t "~a~%" (rfibs 100))
+
+(defun a-fib-sub-cases (a-fib rfibs-ls) ;; return as a vector of lists
+  (let* ((skip 0)
+        (rlen (length rfibs-ls))
+        (rfibs-vec (make-array (list rlen) :initial-contents rfibs-ls)))
+    (setq skip (loop named finding-idx for i from 0 below rlen
+                     for a-rf = (aref rfibs-vec i)
+                     if (= a-rf a-fib) do (return-from finding-idx i)))
+    (if (null skip)
+        '()
+      (let* ((sub-rfib-len (- rlen skip))
+             (all-cases (list (list a-fib))))
+        (loop named generating-subfib
+              for i  from 0 below (- sub-rfib-len 2) by 2
+              for ri = (+ skip i 1)
+              do (let* ((last-fibs (car (last all-cases))) ;; XXX car needed
+                        (two-fibs (list (aref rfibs-vec ri)
+                                        (aref rfibs-vec (1+ ri))))
+                        (last-fibs-withouth-last-one
+                         (reverse (cdr (reverse last-fibs))))
+                        (new-sub-case
+                         (append last-fibs-withouth-last-one two-fibs)))
+
+                   (nconc all-cases (list new-sub-case))))
+        (make-array (list (length all-cases)) :initial-contents all-cases)))))
+
+;;(format t "~a~%"  (a-fib-sub-cases 55 (rfibs 55)))
+
+(defun flat-once (list-of-list)
+  (let ((all '()))
+    (map nil #'(lambda (ls) (setq all (append all ls))) list-of-list)
+    all))
+
+(defun product-cases (cases-map &optional validate-func)
+  (let* ((num-cases (length cases-map))
+         (cases-vec (make-array (list num-cases) :initial-contents cases-map))
+         (pos (make-array (list num-cases) :initial-element 0))
+         (csr (1- num-cases)) ;; pointing the last case
+         (all-cases (list 'remove-me)))
+
+    (loop named processing-cases do
+          (if (< (aref pos csr) (length (aref cases-vec csr)))
+              ;; still have next step at the current cursor
+              (let* ((cur-cases-combi
+                      (mapcar
+                       (lambda (sub-case cur-sub-case-idx)
+                         (coerce (aref sub-case cur-sub-case-idx) 'list))
+                       cases-map (coerce pos 'list))))
+
+                (when (or (null validate-func)
+                          (funcall validate-func cur-cases-combi))
+                  ;; flatten and collect the case
+                  (nconc all-cases (list (flat-once cur-cases-combi))))
+                ;; try next case
+                (setf (aref pos csr) (1+ (aref pos csr))))
+            ;; else -- try to go higher order
+            (let* ((new-csr
+                    (loop named finding-new-cursor
+                          for c from (1- csr) downto 0
+                          if (< (aref pos c) (1- (length (aref cases-vec c))))
+                          do (return-from finding-new-cursor c))))
+              (if (null new-csr)
+                  (return-from processing-cases)
+                (progn
+                  (setf (aref pos new-csr) (1+ (aref pos new-csr)))
+                  (loop for i from (1+ new-csr) below num-cases
+                        do (setf (aref pos i) 0))
+                  (setq csr (1- num-cases)))))))
+    (cdr all-cases)))
+
+
+;; (format t "~a~%"  (product-cases (list (a-fib-sub-cases 55 (rfibs 55))
+;;                                        (a-fib-sub-cases 13 (rfibs 13)))))
+
+(defun product-a-rfibs-combi (a-fibs-combi rfibs-ls) ;; `r' means reversed order
+  (let* ((rcase-map (map 'list
+                      (lambda (a-fib) (a-fib-sub-cases a-fib rfibs-ls))
+                      a-fibs-combi)))
+    (product-cases rcase-map
+                   (lambda (a-combi) ;; validation code
+                     (let* ((left-case (first a-combi))
+                            (overlapped
+                             (loop named finding-duplicated
+                                   for right-case in (cdr a-combi)
+                                   if (<= (car (last left-case)) (first right-case))
+                                   do (return-from finding-duplicated t)
+                                   else
+                                   do (setq left-case right-case))))
+                       (not overlapped))))))
+
+;;(format t "~a~%" (product-a-rfibs-combi '(55 13 5) (rfibs 55)))
+
+(defun a-min-combi-rfib-sum (target-sum rfibs-ls)
+  (let ((major-fib
+         (loop named finding-major-fib for a-fib in rfibs-ls
+               do (if (<= a-fib target-sum)
+                      (return-from finding-major-fib a-fib)
+                    (setq rfibs-ls (cdr rfibs-ls))))))
+    (if (null major-fib)
+        '()
+      ;;
+      (if (= major-fib target-sum)
+          (list major-fib)
+        (let ((rest-fibs (a-min-combi-rfib-sum
+                          (- target-sum major-fib) rfibs-ls)))
+          (if (null rest-fibs)
+              '()
+            (cons major-fib rest-fibs)))))))
+
+;;(format t "~a~%" (a-min-combi-rfib-sum 100 (rfibs 100)))
+
+;; final solution form
+(defun all-combi-fib-sum (target-sum)
+  (let* ((rfibs-ls (rfibs target-sum))
+         (a-sum-combi (a-min-combi-rfib-sum target-sum rfibs-ls)))
+    (if (null a-sum-combi)
+        '()
+      (product-a-rfibs-combi a-sum-combi rfibs-ls))))
+
+(defun get-command-line ()
+  (or
+   #+CLISP *args*
+   #+SBCL *posix-argv*
+   #+LISPWORKS system:*line-arguments-list*
+   #+CMU extensions:*command-line-words*
+   nil))
+
+(defparameter *cmdline* (get-command-line))
+
+(defun print-usage ()
+  (format t "Usage: sbcl --script ch-1.lsp <target-sum>"
+          (first *cmdline*)))
+
+(when (< (length *cmdline*) 2) (print-usage) (quit))
+(defparameter *target-sum* (parse-integer (second *cmdline*)))
+(format t "Input: ~d~%Output:~%" *target-sum*)
+(defvar all-combi (all-combi-fib-sum *target-sum*))
+(map nil (lambda (a-combi)
+           (progn (format t "~{~a~^ + ~}" a-combi)
+                  (format t " = ~a~%" *target-sum*))
+           ) all-combi)
+
+(format t "Total ~d case(s) found.~%" (length all-combi))
diff --git a/challenge-077/jeongoon/haskell/ch-1.hs b/challenge-077/jeongoon/haskell/ch-1.hs
index 6a6bf0296b..9f438205d2 100644
--- a/challenge-077/jeongoon/haskell/ch-1.hs
+++ b/challenge-077/jeongoon/haskell/ch-1.hs
@@ -25,21 +25,18 @@ fibNumbers n = unfoldr (\(x, i) -> let fn = fib i in
 reversedFibNumbers = sortBy (\a b -> compare b a).fibNumbers
 
 -- find the all cases of a fib number can be expressed
-divideAFib :: Integer -> [Integer] -> [Integer] -> [[Integer]]
-divideAFib f [] fibNumsUsed = divideAFib f (reversedFibNumbers f) fibNumsUsed
-divideAFib f rfibNums fibNumsUsed = -- fibNumUsed cannot be used twice or more
+divideAFib :: Integer -> [Integer] -> [[Integer]]
+divideAFib f [] = divideAFib f (reversedFibNumbers f)
+divideAFib f rfibNums =
   case (findIndex (f==) rfibNums) of
     Nothing   -> [] --  wrong fib number
     Just fidx -> [[f]] -- always include one fib number itself
-                      -- which is not effeceted by fibNumsUsed
                 ++ unfoldr divideAFibInner (fidx, rfibNums, [f])
   where
     divideAFibInner (_, [], _) = Nothing -- only for silence warning message
     divideAFibInner (idx, rfs@(_:rfs'), acc)
       | idx +2 >= length rfs = Nothing
-      | null (intersect nextTwoFibs fibNumsUsed) =
-          Just ( acc', (idx+1, rfs', acc' ) )
-      | otherwise = Nothing
+      | otherwise = Just ( acc', (idx+1, rfs', acc' ) )
       where
         nextTwoFibs = [ rfs !! (idx+1), rfs !! (idx+2) ]
         acc' = (init acc) ++ nextTwoFibs
@@ -49,6 +46,7 @@ rExpandFibCombination rfibNumsCombi [] =
   rExpandFibCombination rfibNumsCombi (reversedFibNumbers (head rfibNumsCombi))
 rExpandFibCombination rfibNumsCombi rAllFibNums =
   -- rfibNumsCombi: expect to get reversed sorted fib numbers
+  filter ((0<).length) $
   unfoldr productExpandedCases ((replicate nof 0),
                                  lastCsr ) -- starting from last (smallest) fib.
   where
@@ -56,7 +54,7 @@ rExpandFibCombination rfibNumsCombi rAllFibNums =
     rcases = unfoldr (\fibs
                         -> if null fibs then Nothing
                           else Just( divideAFib
-                                  (head fibs) rAllFibNums (tail fibs),
+                                  (head fibs) rAllFibNums,
                                   (tail fibs) ) ) rfibNumsCombi
 
     nof = length rfibNumsCombi
@@ -70,9 +68,9 @@ rExpandFibCombination rfibNumsCombi rAllFibNums =
     productExpandedCases :: ([Int], Int) -> Maybe ([Integer], ([Int], Int))
     productExpandedCases (pos, csr)
       | null pos       = Nothing
+      | not isValidCase = Just ( [], (pos', csr') )
       | otherwise      =
-          Just ( ((foldr (++) []).(map rCaseAtCursor)) allNumRange,
-                 (pos', csr') )
+          Just ( (foldr (++) [] rCaseCombi), (pos', csr') )
       where
         (pos', csr') = case nextCsr csr of
                          Nothing -> ([], csr) -- make edge case
@@ -86,6 +84,15 @@ rExpandFibCombination rfibNumsCombi rAllFibNums =
 
         rCaseAtCursor :: Int -> [Integer]
         rCaseAtCursor i = ((rcases!!i)!!(pos!!i))
+        rCaseCombi = map rCaseAtCursor allNumRange
+
+        isValidCase = isValidCaseInner (head rCaseCombi) (tail rCaseCombi)
+          where
+            isValidCaseInner _ [] = True
+            isValidCaseInner leftCase (rightCase:moreRestCases)
+              | (last leftCase) <= (head rightCase) = False
+              | otherwise = isValidCaseInner rightCase moreRestCases
+
 
         fibAtCursorHasMoreCases c = ((length (rcases!!c)) -1) /= pos!!c