;; -*- coding: utf-8 -*- (eval-when (:compile-toplevel :load-toplevel :execute) (sb-int:defconstant-eqx OPT #+swank '(optimize (speed 3) (safety 2)) #-swank '(optimize (speed 3) (safety 0) (debug 0)) #'equal) #+swank (ql:quickload '(:cl-debug-print :fiveam) :silent t) #-swank (set-dispatch-macro-character #\# #\> (lambda (s c p) (declare (ignore c p)) (read s nil nil t)))) #+swank (cl-syntax:use-syntax cl-debug-print:debug-print-syntax) #-swank (disable-debugger) ; for CS Academy ;; BEGIN_INSERTED_CONTENTS ;;; ;;; Memoization macro ;;; ;; ;; Basic usage: ;; ;; (with-cache (:hash-table :test #'equal :key #'cons) ;; (defun add (a b) ;; (+ a b))) ;; This function caches the returned values for already passed combinations of ;; arguments. In this case ADD stores the key (CONS A B) and the return value to ;; a hash-table when evaluating (ADD A B) for the first time. ADD returns the ;; stored value when it is called with the same arguments (w.r.t. EQUAL) again. ;; ;; The storage for the cache is hash-table or array. Let's see an example for ;; array: ;; (with-cache (:array (10 20 30) :initial-element -1 :element-type 'fixnum) ;; (defun foo (a b c) ... )) ;; This form stores the value of FOO in the array created by (make-array (list ;; 10 20 30) :initial-element -1 :element-type 'fixnum). Note that ;; INITIAL-ELEMENT must always be given here as it is used as the flag for `not ;; yet stored'. (Therefore INITIAL-ELEMENT should be a value FOO never takes.) ;; ;; If you want to ignore some arguments, you can put `*' in dimensions: ;; (with-cache (:array (10 10 * 10) :initial-element -1) ;; (defun foo (a b c d) ...)) ; then C is ignored when querying or storing cache ;; ;; Available definition forms in WITH-CACHE are DEFUN, LABELS, FLET, and ;; SB-INT:NAMED-LET. ;; ;; You can trace the memoized function by :TRACE option: ;; (with-cache (:array (10 10) :initial-element -1 :trace t) ;; (defun foo (x y) ...)) ;; Then FOO is traced as with CL:TRACE. ;; ;; TODO & NOTE: Currently a memoized function is not enclosed with a block of ;; the function name. ;; FIXME: *RECURSION-DEPTH* should be included within the macro. (declaim (type (integer 0 #.most-positive-fixnum) *recursion-depth*)) (defparameter *recursion-depth* 0) (eval-when (:compile-toplevel :load-toplevel :execute) (defun %enclose-with-trace (fname args form) (let ((value (gensym))) `(progn (format t "~&~A~A: (~A ~{~A~^ ~}) =>" (make-string *recursion-depth* :element-type 'base-char :initial-element #\ ) *recursion-depth* ',fname (list ,@args)) (let ((,value (let ((*recursion-depth* (1+ *recursion-depth*))) ,form))) (format t "~&~A~A: (~A ~{~A~^ ~}) => ~A" (make-string *recursion-depth* :element-type 'base-char :initial-element #\ ) *recursion-depth* ',fname (list ,@args) ,value) ,value)))) (defun %extract-declarations (body) (remove-if-not (lambda (form) (and (consp form) (eql 'declare (car form)))) body)) (defun %parse-cache-form (cache-specifier) (let ((cache-type (car cache-specifier)) (cache-attribs (cdr cache-specifier))) (assert (member cache-type '(:hash-table :array))) (let* ((dims-with-* (when (eql cache-type :array) (first cache-attribs))) (dims (remove '* dims-with-*)) (rank (length dims)) (rest-attribs (ecase cache-type (:hash-table cache-attribs) (:array (cdr cache-attribs)))) (key (prog1 (getf rest-attribs :key) (remf rest-attribs :key))) (trace-p (prog1 (getf rest-attribs :trace) (remf rest-attribs :trace))) (cache-form (case cache-type (:hash-table `(make-hash-table ,@rest-attribs)) (:array `(make-array (list ,@dims) ,@rest-attribs)))) (initial-element (when (eql cache-type :array) (assert (member :initial-element rest-attribs)) (getf rest-attribs :initial-element)))) (let ((cache (gensym "CACHE")) (value (gensym)) (present-p (gensym)) (name-alias (gensym)) (args-lst (gensym)) (indices (loop repeat rank collect (gensym)))) (labels ((make-cache-querier (cache-type name args) (let ((res (case cache-type (:hash-table `(let ((,args-lst (funcall ,(or key #'list) ,@args))) (multiple-value-bind (,value ,present-p) (gethash ,args-lst ,cache) (if ,present-p ,value (setf (gethash ,args-lst ,cache) (,name-alias ,@args)))))) (:array (let ((memoized-args (loop for dimension in dims-with-* for arg in args unless (eql dimension '*) collect arg))) (if key `(multiple-value-bind ,indices (funcall ,key ,@memoized-args) (let ((,value (aref ,cache ,@indices))) (if (eql ,initial-element ,value) (setf (aref ,cache ,@indices) (,name-alias ,@args)) ,value))) `(let ((,value (aref ,cache ,@memoized-args))) (if (eql ,initial-element ,value) (setf (aref ,cache ,@memoized-args) (,name-alias ,@args)) ,value)))))))) (if trace-p (%enclose-with-trace name args res) res))) (make-reset-form (cache-type) (case cache-type (:hash-table `(setf ,cache (make-hash-table ,@rest-attribs))) (:array `(prog1 nil (fill (array-storage-vector ,cache) ,initial-element))))) (make-reset-name (name) (intern (format nil "RESET-~A" (symbol-name name))))) (values cache cache-form cache-type name-alias #'make-reset-name #'make-reset-form #'make-cache-querier))))))) (defmacro with-cache ((cache-type &rest cache-attribs) def-form) "CACHE-TYPE := :HASH-TABLE | :ARRAY. DEF-FORM := definition form with DEFUN, LABELS, FLET, or SB-INT:NAMED-LET." (multiple-value-bind (cache-symbol cache-form cache-type name-alias make-reset-name make-reset-form make-cache-querier) (%parse-cache-form (cons cache-type cache-attribs)) (ecase (car def-form) ((defun) (destructuring-bind (_ name args &body body) def-form (declare (ignore _)) `(let ((,cache-symbol ,cache-form)) (defun ,(funcall make-reset-name name) () ,(funcall make-reset-form cache-type)) (defun ,name ,args ,@(%extract-declarations body) (labels ((,name-alias ,args ,@body)) (declare (inline ,name-alias)) ,(funcall make-cache-querier cache-type name args)))))) ((labels flet) (destructuring-bind (_ definitions &body labels-body) def-form (declare (ignore _)) (destructuring-bind (name args &body body) (car definitions) `(let ((,cache-symbol ,cache-form)) (,(car def-form) ((,(funcall make-reset-name name) () ,(funcall make-reset-form cache-type)) (,name ,args ,@(%extract-declarations body) (labels ((,name-alias ,args ,@body)) (declare (inline ,name-alias)) ,(funcall make-cache-querier cache-type name args))) ,@(cdr definitions)) (declare (ignorable #',(funcall make-reset-name name))) ,@labels-body))))) ((nlet #+sbcl sb-int:named-let) (destructuring-bind (_ name bindings &body body) def-form (declare (ignore _)) `(let ((,cache-symbol ,cache-form)) (,(car def-form) ,name ,bindings ,@(%extract-declarations body) ,(let ((args (mapcar (lambda (x) (if (atom x) x (car x))) bindings))) `(labels ((,name-alias ,args ,@body)) (declare (inline ,name-alias)) ,(funcall make-cache-querier cache-type name args)))))))))) (defmacro with-caches (cache-specs def-form) "DEF-FORM := definition form by LABELS or FLET. (with-caches (cache-spec1 cache-spec2) (labels ((f (x) ...) (g (y) ...)))) is equivalent to the line up of (with-cache cache-spec1 (labels ((f (x) ...)))) and (with-cache cache-spec2 (labels ((g (y) ...)))) This macro will be useful to do mutual recursion between memoized local functions." (assert (member (car def-form) '(labels flet))) (let (cache-symbol-list cache-form-list cache-type-list name-alias-list make-reset-name-list make-reset-form-list make-cache-querier-list) (dolist (cache-spec (reverse cache-specs)) (multiple-value-bind (cache-symbol cache-form cache-type name-alias make-reset-name make-reset-form make-cache-querier) (%parse-cache-form cache-spec) (push cache-symbol cache-symbol-list) (push cache-form cache-form-list) (push cache-type cache-type-list) (push name-alias name-alias-list) (push make-reset-name make-reset-name-list) (push make-reset-form make-reset-form-list) (push make-cache-querier make-cache-querier-list))) (labels ((def-name (def) (first def)) (def-args (def) (second def)) (def-body (def) (cddr def))) (destructuring-bind (_ definitions &body labels-body) def-form (declare (ignore _)) `(let ,(loop for cache-symbol in cache-symbol-list for cache-form in cache-form-list collect `(,cache-symbol ,cache-form)) (,(car def-form) (,@(loop for def in definitions for cache-type in cache-type-list for make-reset-name in make-reset-name-list for make-reset-form in make-reset-form-list collect `(,(funcall make-reset-name (def-name def)) () ,(funcall make-reset-form cache-type))) ,@(loop for def in definitions for cache-type in cache-type-list for name-alias in name-alias-list for make-cache-querier in make-cache-querier-list collect `(,(def-name def) ,(def-args def) ,@(%extract-declarations (def-body def)) (labels ((,name-alias ,(def-args def) ,@(def-body def))) (declare (inline ,name-alias)) ,(funcall make-cache-querier cache-type (def-name def) (def-args def)))))) (declare (ignorable ,@(loop for def in definitions for make-reset-name in make-reset-name-list collect `#',(funcall make-reset-name (def-name def))))) ,@labels-body)))))) (declaim (ftype (function * (values fixnum &optional)) read-fixnum)) (defun read-fixnum (&optional (in *standard-input*)) (declare #.OPT) (macrolet ((%read-byte () `(the (unsigned-byte 8) #+swank (char-code (read-char in nil #\Nul)) #-swank (sb-impl::ansi-stream-read-byte in nil #.(char-code #\Nul) nil)))) (let* ((minus nil) (result (loop (let ((byte (%read-byte))) (cond ((<= 48 byte 57) (return (- byte 48))) ((zerop byte) ; #\Nul (error "Read EOF or #\Nul.")) ((= byte #.(char-code #\-)) (setf minus t))))))) (declare ((integer 0 #.most-positive-fixnum) result)) (loop (let* ((byte (%read-byte))) (if (<= 48 byte 57) (setq result (+ (- byte 48) (* 10 (the (integer 0 #.(floor most-positive-fixnum 10)) result)))) (return (if minus (- result) result)))))))) (defmacro dbg (&rest forms) #+swank (if (= (length forms) 1) `(format *error-output* "~A => ~A~%" ',(car forms) ,(car forms)) `(format *error-output* "~A => ~A~%" ',forms `(,,@forms))) #-swank (declare (ignore forms))) (defmacro define-int-types (&rest bits) `(progn ,@(mapcar (lambda (b) `(deftype ,(intern (format nil "UINT~A" b)) () '(unsigned-byte ,b))) bits) ,@(mapcar (lambda (b) `(deftype ,(intern (format nil "INT~A" b)) () '(signed-byte ,b))) bits))) (define-int-types 2 4 7 8 15 16 31 32 62 63 64) (declaim (inline println)) (defun println (obj &optional (stream *standard-output*)) (let ((*read-default-float-format* 'double-float)) (prog1 (princ obj stream) (terpri stream)))) (defconstant +mod+ 1000000007) ;;; ;;; Body ;;; (defconstant +inf+ #x7fffffff) (define-modify-macro minf (new-value) min) (defun main () (let* ((n (read)) (c (read)) (v (read)) (revgraph (make-array n :element-type 'list :initial-element nil)) (ss (make-array v :element-type 'uint32)) (ts (make-array v :element-type 'uint32)) (ys (make-array v :element-type 'uint32)) (ms (make-array v :element-type 'uint32))) (declare (uint16 n c v)) (dotimes (i v) (setf (aref ss i) (- (read-fixnum) 1))) (dotimes (i v) (setf (aref ts i) (- (read-fixnum) 1))) (dotimes (i v) (setf (aref ys i) (read-fixnum))) (dotimes (i v) (setf (aref ms i) (read-fixnum))) (dotimes (i v) (push (list* (aref ss i) (aref ys i) (aref ms i)) (aref revgraph (aref ts i)))) (with-cache (:array (n (+ c 1)) :element-type 'uint32 :initial-element #xffffffff) (labels ((recur (v fund) (if (zerop v) 0 (let ((res +inf+)) (declare (uint32 res)) (dolist (edge (aref revgraph v)) (destructuring-bind (prev yen . minute) edge (declare (uint32 prev yen minute)) (when (>= fund yen) (minf res (+ minute (recur prev (- fund yen))))))) res)))) (println (if (= +inf+ (recur (- n 1) c)) -1 (recur (- n 1) c))))))) #-swank (main) ;;; ;;; Test and benchmark ;;; #+swank (defun io-equal (in-string out-string &key (function #'main) (test #'equal)) "Passes IN-STRING to *STANDARD-INPUT*, executes FUNCTION, and returns true if the string output to *STANDARD-OUTPUT* is equal to OUT-STRING." (labels ((ensure-last-lf (s) (if (eql (uiop:last-char s) #\Linefeed) s (uiop:strcat s uiop:+lf+)))) (funcall test (ensure-last-lf out-string) (with-output-to-string (out) (let ((*standard-output* out)) (with-input-from-string (*standard-input* (ensure-last-lf in-string)) (funcall function))))))) #+swank (defun get-clipbrd () (with-output-to-string (out) (run-program "C:/msys64/usr/bin/cat.exe" '("/dev/clipboard") :output out))) #+swank (defparameter *this-pathname* (uiop:current-lisp-file-pathname)) #+swank (defparameter *dat-pathname* (uiop:merge-pathnames* "test.dat" *this-pathname*)) #+swank (defun run (&optional thing (out *standard-output*)) "THING := null | string | symbol | pathname null: run #'MAIN using the text on clipboard as input. string: run #'MAIN using the string as input. symbol: alias of FIVEAM:RUN!. pathname: run #'MAIN using the text file as input." (let ((*standard-output* out)) (etypecase thing (null (with-input-from-string (*standard-input* (delete #\Return (get-clipbrd))) (main))) (string (with-input-from-string (*standard-input* (delete #\Return thing)) (main))) (symbol (5am:run! thing)) (pathname (with-open-file (*standard-input* thing) (main)))))) #+swank (defun gen-dat () (uiop:with-output-file (out *dat-pathname* :if-exists :supersede) (format out ""))) #+swank (defun bench (&optional (out (make-broadcast-stream))) (time (run *dat-pathname* out)))