From ac10c4067a5401a6088ba6ba95f371e57af5714b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 Feb 2008 19:31:55 -0500 Subject: [PATCH 01/42] Better method for getting last digits of an integer --- extra/project-euler/032/032.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 2baa6f8714..e03ab6f89b 100644 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.lib hashtables kernel math math.combinatorics math.parser - math.ranges project-euler.common sequences ; +USING: combinators.lib hashtables kernel math math.combinatorics math.functions + math.parser math.ranges project-euler.common sequences ; IN: project-euler.032 ! http://projecteuler.net/index.php?section=problems&id=32 @@ -41,7 +41,7 @@ IN: project-euler.032 dup 1and4 swap 2and3 or ; : products ( seq -- m ) - [ number>string 4 tail* 10 string>integer ] map ; + [ 10 4 ^ mod ] map ; PRIVATE> @@ -49,7 +49,7 @@ PRIVATE> source-032 [ valid? ] subset products prune sum ; ! [ euler032 ] 10 ave-time -! 27609 ms run / 2484 ms GC ave time - 10 trials +! 23922 ms run / 1505 ms GC ave time - 10 trials ! ALTERNATE SOLUTIONS From 1954114d85e75a13b2274a093af8d4f94372f024 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 Feb 2008 19:42:47 -0500 Subject: [PATCH 02/42] Solution to Project Euler problem 48 --- extra/project-euler/048/048.factor | 25 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 4 ++-- 2 files changed, 27 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/048/048.factor diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor new file mode 100644 index 0000000000..ba58792987 --- /dev/null +++ b/extra/project-euler/048/048.factor @@ -0,0 +1,25 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math math.functions ; +IN: project-euler.048 + +! http://projecteuler.net/index.php?section=problems&id=48 + +! DESCRIPTION +! ----------- + +! The series, 1^1 + 2^2 + 3^3 + ... + 10^10 = 10405071317. + +! Find the last ten digits of the series, 1^1 + 2^2 + 3^3 + ... + 1000^1000. + + +! SOLUTION +! -------- + +: euler048 ( -- answer ) + 1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ; + +! [ euler048 ] 100 ave-time +! 276 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler048 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index eb9d7d1300..d89453eb14 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,8 +12,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.067 project-euler.075 project-euler.134 project-euler.169 - project-euler.173 project-euler.175 ; + project-euler.048 project-euler.067 project-euler.075 project-euler.134 + project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Sun, 3 Feb 2008 16:15:03 -0500 Subject: [PATCH 03/42] Solution to Project Euler problem 41 --- extra/project-euler/041/041.factor | 40 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 4 +-- 2 files changed, 42 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/041/041.factor diff --git a/extra/project-euler/041/041.factor b/extra/project-euler/041/041.factor new file mode 100644 index 0000000000..60017f39a1 --- /dev/null +++ b/extra/project-euler/041/041.factor @@ -0,0 +1,40 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math.combinatorics math.parser math.primes sequences ; +IN: project-euler.041 + +! http://projecteuler.net/index.php?section=problems&id=41 + +! DESCRIPTION +! ----------- + +! We shall say that an n-digit number is pandigital if it makes use of all the +! digits 1 to n exactly once. For example, 2143 is a 4-digit pandigital and is +! also prime. + +! What is the largest n-digit pandigital prime that exists? + + +! SOLUTION +! -------- + +! Check 7-digit pandigitals because if the sum of the digits in any number add +! up to a multiple of three, then it is a multiple of three and can't be prime. +! I assumed there would be a 7-digit answer, but technically a higher 4-digit +! pandigital than the one given in the description was also possible. + +! 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 = 45 +! 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 = 36 +! 1 + 2 + 3 + 4 + 5 + 6 + 7 = 28 *** not divisible by 3 *** +! 1 + 2 + 3 + 4 + 5 + 6 = 21 +! 1 + 2 + 3 + 4 + 5 = 15 +! 1 + 2 + 3 + 4 = 10 *** not divisible by 3 *** + +: euler041 ( -- answer ) + { 7 6 5 4 3 2 1 } all-permutations + [ 10 swap digits>integer ] map [ prime? ] find nip ; + +! [ euler041 ] 100 ave-time +! 107 ms run / 7 ms GC ave time - 100 trials + +MAIN: euler041 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index d89453eb14..3433fe7154 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,8 +12,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.048 project-euler.067 project-euler.075 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.048 project-euler.067 project-euler.075 + project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Sun, 3 Feb 2008 17:18:10 -0500 Subject: [PATCH 04/42] Fix common Project Euler word alpha-num --- extra/project-euler/022/022.factor | 10 +++------- extra/project-euler/common/common.factor | 6 +++++- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index e9b0b5fbcf..9c8866b736 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -1,7 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel math math.parser namespaces sequences sorting splitting - strings system vocabs ascii ; +USING: ascii io.files kernel math project-euler.common sequences sorting splitting ; IN: project-euler.022 ! http://projecteuler.net/index.php?section=problems&id=22 @@ -31,9 +30,6 @@ IN: project-euler.022 "extra/project-euler/022/names.txt" resource-path file-contents [ quotable? ] subset "," split ; -: alpha-value ( str -- n ) - [ string>digits sum ] keep length 9 * - ; - : name-scores ( seq -- seq ) dup length [ 1+ swap alpha-value * ] 2map ; @@ -43,9 +39,9 @@ PRIVATE> source-022 natural-sort name-scores sum ; ! [ euler022 ] 100 ave-time -! 59 ms run / 1 ms GC ave time - 100 trials +! 123 ms run / 4 ms GC ave time - 100 trials ! source-022 [ natural-sort name-scores sum ] curry 100 ave-time -! 45 ms run / 1 ms GC ave time - 100 trials +! 93 ms run / 2 ms GC ave time - 100 trials MAIN: euler022 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 50adbe4953..99bb3169c4 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,6 +1,6 @@ USING: arrays combinators.lib kernel math math.functions math.miller-rabin math.matrices math.parser math.primes.factors math.ranges namespaces - sequences sorting ; + sequences sorting unicode.case ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -8,6 +8,7 @@ IN: project-euler.common ! Problems using each public word ! ------------------------------- +! alpha-value - #22, #42 ! cartesian-product - #4, #27, #29, #32, #33 ! collect-consecutive - #8, #11 ! log10 - #25, #134 @@ -52,6 +53,9 @@ IN: project-euler.common PRIVATE> +: alpha-value ( str -- n ) + >lower [ CHAR: a - 1+ ] sigma ; + : cartesian-product ( seq1 seq2 -- seq1xseq2 ) swap [ swap [ 2array ] map-with ] map-with concat ; From c64fe3d07bfe6f91d22dcc586a81a289a82c255f Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 3 Feb 2008 18:42:45 -0500 Subject: [PATCH 05/42] Solution to Project Euler problem 42 --- extra/project-euler/012/012.factor | 3 - extra/project-euler/022/022.factor | 3 - extra/project-euler/042/042.factor | 74 ++++++++++++++++++++++++ extra/project-euler/042/words.txt | 1 + extra/project-euler/067/067.factor | 3 - extra/project-euler/common/common.factor | 4 ++ extra/project-euler/project-euler.factor | 5 +- 7 files changed, 82 insertions(+), 11 deletions(-) create mode 100644 extra/project-euler/042/042.factor create mode 100644 extra/project-euler/042/words.txt diff --git a/extra/project-euler/012/012.factor b/extra/project-euler/012/012.factor index 3d59549e69..583bad8f72 100644 --- a/extra/project-euler/012/012.factor +++ b/extra/project-euler/012/012.factor @@ -33,9 +33,6 @@ IN: project-euler.012 ! SOLUTION ! -------- -: nth-triangle ( n -- n ) - dup 1+ * 2 / ; - : euler012 ( -- answer ) 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ; diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 9c8866b736..5bd1797272 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -41,7 +41,4 @@ PRIVATE> ! [ euler022 ] 100 ave-time ! 123 ms run / 4 ms GC ave time - 100 trials -! source-022 [ natural-sort name-scores sum ] curry 100 ave-time -! 93 ms run / 2 ms GC ave time - 100 trials - MAIN: euler022 diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor new file mode 100644 index 0000000000..3d5f271374 --- /dev/null +++ b/extra/project-euler/042/042.factor @@ -0,0 +1,74 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: ascii combinators.lib io.files kernel math namespaces + project-euler.common sequences splitting ; +IN: project-euler.042 + +! http://projecteuler.net/index.php?section=problems&id=42 + +! DESCRIPTION +! ----------- + +! The nth term of the sequence of triangle numbers is given by, +! tn = n * (n + 1) / 2; so the first ten triangle numbers are: + +! 1, 3, 6, 10, 15, 21, 28, 36, 45, 55, ... + +! By converting each letter in a word to a number corresponding to its +! alphabetical position and adding these values we form a word value. For +! example, the word value for SKY is 19 + 11 + 25 = 55 = t10. If the word value +! is a triangle number then we shall call the word a triangle word. + +! Using words.txt (right click and 'Save Link/Target As...'), a 16K text file +! containing nearly two-thousand common English words, how many are triangle +! words? + + +! SOLUTION +! -------- + + [ + dup nth-triangle , 1+ (triangle-upto) + ] [ + 2drop + ] if ; + +: triangle-upto ( n -- seq ) + [ 1 (triangle-upto) ] { } make ; + +PRIVATE> + +: euler042 ( -- answer ) + source-042 [ alpha-value ] map dup supremum + triangle-upto [ member? ] curry count ; + +! [ euler042 ] 100 ave-time +! 27 ms run / 1 ms GC ave time - 100 trials + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Use the inverse function of n * (n + 1) / 2 and test if the result is an integer + + + +: euler042a ( -- answer ) + source-042 [ alpha-value ] map [ triangle? ] count ; + +! [ euler042a ] 100 ave-time +! 25 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler042a diff --git a/extra/project-euler/042/words.txt b/extra/project-euler/042/words.txt new file mode 100644 index 0000000000..7177624d41 --- /dev/null +++ b/extra/project-euler/042/words.txt @@ -0,0 +1 @@ +"A","ABILITY","ABLE","ABOUT","ABOVE","ABSENCE","ABSOLUTELY","ACADEMIC","ACCEPT","ACCESS","ACCIDENT","ACCOMPANY","ACCORDING","ACCOUNT","ACHIEVE","ACHIEVEMENT","ACID","ACQUIRE","ACROSS","ACT","ACTION","ACTIVE","ACTIVITY","ACTUAL","ACTUALLY","ADD","ADDITION","ADDITIONAL","ADDRESS","ADMINISTRATION","ADMIT","ADOPT","ADULT","ADVANCE","ADVANTAGE","ADVICE","ADVISE","AFFAIR","AFFECT","AFFORD","AFRAID","AFTER","AFTERNOON","AFTERWARDS","AGAIN","AGAINST","AGE","AGENCY","AGENT","AGO","AGREE","AGREEMENT","AHEAD","AID","AIM","AIR","AIRCRAFT","ALL","ALLOW","ALMOST","ALONE","ALONG","ALREADY","ALRIGHT","ALSO","ALTERNATIVE","ALTHOUGH","ALWAYS","AMONG","AMONGST","AMOUNT","AN","ANALYSIS","ANCIENT","AND","ANIMAL","ANNOUNCE","ANNUAL","ANOTHER","ANSWER","ANY","ANYBODY","ANYONE","ANYTHING","ANYWAY","APART","APPARENT","APPARENTLY","APPEAL","APPEAR","APPEARANCE","APPLICATION","APPLY","APPOINT","APPOINTMENT","APPROACH","APPROPRIATE","APPROVE","AREA","ARGUE","ARGUMENT","ARISE","ARM","ARMY","AROUND","ARRANGE","ARRANGEMENT","ARRIVE","ART","ARTICLE","ARTIST","AS","ASK","ASPECT","ASSEMBLY","ASSESS","ASSESSMENT","ASSET","ASSOCIATE","ASSOCIATION","ASSUME","ASSUMPTION","AT","ATMOSPHERE","ATTACH","ATTACK","ATTEMPT","ATTEND","ATTENTION","ATTITUDE","ATTRACT","ATTRACTIVE","AUDIENCE","AUTHOR","AUTHORITY","AVAILABLE","AVERAGE","AVOID","AWARD","AWARE","AWAY","AYE","BABY","BACK","BACKGROUND","BAD","BAG","BALANCE","BALL","BAND","BANK","BAR","BASE","BASIC","BASIS","BATTLE","BE","BEAR","BEAT","BEAUTIFUL","BECAUSE","BECOME","BED","BEDROOM","BEFORE","BEGIN","BEGINNING","BEHAVIOUR","BEHIND","BELIEF","BELIEVE","BELONG","BELOW","BENEATH","BENEFIT","BESIDE","BEST","BETTER","BETWEEN","BEYOND","BIG","BILL","BIND","BIRD","BIRTH","BIT","BLACK","BLOCK","BLOOD","BLOODY","BLOW","BLUE","BOARD","BOAT","BODY","BONE","BOOK","BORDER","BOTH","BOTTLE","BOTTOM","BOX","BOY","BRAIN","BRANCH","BREAK","BREATH","BRIDGE","BRIEF","BRIGHT","BRING","BROAD","BROTHER","BUDGET","BUILD","BUILDING","BURN","BUS","BUSINESS","BUSY","BUT","BUY","BY","CABINET","CALL","CAMPAIGN","CAN","CANDIDATE","CAPABLE","CAPACITY","CAPITAL","CAR","CARD","CARE","CAREER","CAREFUL","CAREFULLY","CARRY","CASE","CASH","CAT","CATCH","CATEGORY","CAUSE","CELL","CENTRAL","CENTRE","CENTURY","CERTAIN","CERTAINLY","CHAIN","CHAIR","CHAIRMAN","CHALLENGE","CHANCE","CHANGE","CHANNEL","CHAPTER","CHARACTER","CHARACTERISTIC","CHARGE","CHEAP","CHECK","CHEMICAL","CHIEF","CHILD","CHOICE","CHOOSE","CHURCH","CIRCLE","CIRCUMSTANCE","CITIZEN","CITY","CIVIL","CLAIM","CLASS","CLEAN","CLEAR","CLEARLY","CLIENT","CLIMB","CLOSE","CLOSELY","CLOTHES","CLUB","COAL","CODE","COFFEE","COLD","COLLEAGUE","COLLECT","COLLECTION","COLLEGE","COLOUR","COMBINATION","COMBINE","COME","COMMENT","COMMERCIAL","COMMISSION","COMMIT","COMMITMENT","COMMITTEE","COMMON","COMMUNICATION","COMMUNITY","COMPANY","COMPARE","COMPARISON","COMPETITION","COMPLETE","COMPLETELY","COMPLEX","COMPONENT","COMPUTER","CONCENTRATE","CONCENTRATION","CONCEPT","CONCERN","CONCERNED","CONCLUDE","CONCLUSION","CONDITION","CONDUCT","CONFERENCE","CONFIDENCE","CONFIRM","CONFLICT","CONGRESS","CONNECT","CONNECTION","CONSEQUENCE","CONSERVATIVE","CONSIDER","CONSIDERABLE","CONSIDERATION","CONSIST","CONSTANT","CONSTRUCTION","CONSUMER","CONTACT","CONTAIN","CONTENT","CONTEXT","CONTINUE","CONTRACT","CONTRAST","CONTRIBUTE","CONTRIBUTION","CONTROL","CONVENTION","CONVERSATION","COPY","CORNER","CORPORATE","CORRECT","COS","COST","COULD","COUNCIL","COUNT","COUNTRY","COUNTY","COUPLE","COURSE","COURT","COVER","CREATE","CREATION","CREDIT","CRIME","CRIMINAL","CRISIS","CRITERION","CRITICAL","CRITICISM","CROSS","CROWD","CRY","CULTURAL","CULTURE","CUP","CURRENT","CURRENTLY","CURRICULUM","CUSTOMER","CUT","DAMAGE","DANGER","DANGEROUS","DARK","DATA","DATE","DAUGHTER","DAY","DEAD","DEAL","DEATH","DEBATE","DEBT","DECADE","DECIDE","DECISION","DECLARE","DEEP","DEFENCE","DEFENDANT","DEFINE","DEFINITION","DEGREE","DELIVER","DEMAND","DEMOCRATIC","DEMONSTRATE","DENY","DEPARTMENT","DEPEND","DEPUTY","DERIVE","DESCRIBE","DESCRIPTION","DESIGN","DESIRE","DESK","DESPITE","DESTROY","DETAIL","DETAILED","DETERMINE","DEVELOP","DEVELOPMENT","DEVICE","DIE","DIFFERENCE","DIFFERENT","DIFFICULT","DIFFICULTY","DINNER","DIRECT","DIRECTION","DIRECTLY","DIRECTOR","DISAPPEAR","DISCIPLINE","DISCOVER","DISCUSS","DISCUSSION","DISEASE","DISPLAY","DISTANCE","DISTINCTION","DISTRIBUTION","DISTRICT","DIVIDE","DIVISION","DO","DOCTOR","DOCUMENT","DOG","DOMESTIC","DOOR","DOUBLE","DOUBT","DOWN","DRAW","DRAWING","DREAM","DRESS","DRINK","DRIVE","DRIVER","DROP","DRUG","DRY","DUE","DURING","DUTY","EACH","EAR","EARLY","EARN","EARTH","EASILY","EAST","EASY","EAT","ECONOMIC","ECONOMY","EDGE","EDITOR","EDUCATION","EDUCATIONAL","EFFECT","EFFECTIVE","EFFECTIVELY","EFFORT","EGG","EITHER","ELDERLY","ELECTION","ELEMENT","ELSE","ELSEWHERE","EMERGE","EMPHASIS","EMPLOY","EMPLOYEE","EMPLOYER","EMPLOYMENT","EMPTY","ENABLE","ENCOURAGE","END","ENEMY","ENERGY","ENGINE","ENGINEERING","ENJOY","ENOUGH","ENSURE","ENTER","ENTERPRISE","ENTIRE","ENTIRELY","ENTITLE","ENTRY","ENVIRONMENT","ENVIRONMENTAL","EQUAL","EQUALLY","EQUIPMENT","ERROR","ESCAPE","ESPECIALLY","ESSENTIAL","ESTABLISH","ESTABLISHMENT","ESTATE","ESTIMATE","EVEN","EVENING","EVENT","EVENTUALLY","EVER","EVERY","EVERYBODY","EVERYONE","EVERYTHING","EVIDENCE","EXACTLY","EXAMINATION","EXAMINE","EXAMPLE","EXCELLENT","EXCEPT","EXCHANGE","EXECUTIVE","EXERCISE","EXHIBITION","EXIST","EXISTENCE","EXISTING","EXPECT","EXPECTATION","EXPENDITURE","EXPENSE","EXPENSIVE","EXPERIENCE","EXPERIMENT","EXPERT","EXPLAIN","EXPLANATION","EXPLORE","EXPRESS","EXPRESSION","EXTEND","EXTENT","EXTERNAL","EXTRA","EXTREMELY","EYE","FACE","FACILITY","FACT","FACTOR","FACTORY","FAIL","FAILURE","FAIR","FAIRLY","FAITH","FALL","FAMILIAR","FAMILY","FAMOUS","FAR","FARM","FARMER","FASHION","FAST","FATHER","FAVOUR","FEAR","FEATURE","FEE","FEEL","FEELING","FEMALE","FEW","FIELD","FIGHT","FIGURE","FILE","FILL","FILM","FINAL","FINALLY","FINANCE","FINANCIAL","FIND","FINDING","FINE","FINGER","FINISH","FIRE","FIRM","FIRST","FISH","FIT","FIX","FLAT","FLIGHT","FLOOR","FLOW","FLOWER","FLY","FOCUS","FOLLOW","FOLLOWING","FOOD","FOOT","FOOTBALL","FOR","FORCE","FOREIGN","FOREST","FORGET","FORM","FORMAL","FORMER","FORWARD","FOUNDATION","FREE","FREEDOM","FREQUENTLY","FRESH","FRIEND","FROM","FRONT","FRUIT","FUEL","FULL","FULLY","FUNCTION","FUND","FUNNY","FURTHER","FUTURE","GAIN","GAME","GARDEN","GAS","GATE","GATHER","GENERAL","GENERALLY","GENERATE","GENERATION","GENTLEMAN","GET","GIRL","GIVE","GLASS","GO","GOAL","GOD","GOLD","GOOD","GOVERNMENT","GRANT","GREAT","GREEN","GREY","GROUND","GROUP","GROW","GROWING","GROWTH","GUEST","GUIDE","GUN","HAIR","HALF","HALL","HAND","HANDLE","HANG","HAPPEN","HAPPY","HARD","HARDLY","HATE","HAVE","HE","HEAD","HEALTH","HEAR","HEART","HEAT","HEAVY","HELL","HELP","HENCE","HER","HERE","HERSELF","HIDE","HIGH","HIGHLY","HILL","HIM","HIMSELF","HIS","HISTORICAL","HISTORY","HIT","HOLD","HOLE","HOLIDAY","HOME","HOPE","HORSE","HOSPITAL","HOT","HOTEL","HOUR","HOUSE","HOUSEHOLD","HOUSING","HOW","HOWEVER","HUGE","HUMAN","HURT","HUSBAND","I","IDEA","IDENTIFY","IF","IGNORE","ILLUSTRATE","IMAGE","IMAGINE","IMMEDIATE","IMMEDIATELY","IMPACT","IMPLICATION","IMPLY","IMPORTANCE","IMPORTANT","IMPOSE","IMPOSSIBLE","IMPRESSION","IMPROVE","IMPROVEMENT","IN","INCIDENT","INCLUDE","INCLUDING","INCOME","INCREASE","INCREASED","INCREASINGLY","INDEED","INDEPENDENT","INDEX","INDICATE","INDIVIDUAL","INDUSTRIAL","INDUSTRY","INFLUENCE","INFORM","INFORMATION","INITIAL","INITIATIVE","INJURY","INSIDE","INSIST","INSTANCE","INSTEAD","INSTITUTE","INSTITUTION","INSTRUCTION","INSTRUMENT","INSURANCE","INTEND","INTENTION","INTEREST","INTERESTED","INTERESTING","INTERNAL","INTERNATIONAL","INTERPRETATION","INTERVIEW","INTO","INTRODUCE","INTRODUCTION","INVESTIGATE","INVESTIGATION","INVESTMENT","INVITE","INVOLVE","IRON","IS","ISLAND","ISSUE","IT","ITEM","ITS","ITSELF","JOB","JOIN","JOINT","JOURNEY","JUDGE","JUMP","JUST","JUSTICE","KEEP","KEY","KID","KILL","KIND","KING","KITCHEN","KNEE","KNOW","KNOWLEDGE","LABOUR","LACK","LADY","LAND","LANGUAGE","LARGE","LARGELY","LAST","LATE","LATER","LATTER","LAUGH","LAUNCH","LAW","LAWYER","LAY","LEAD","LEADER","LEADERSHIP","LEADING","LEAF","LEAGUE","LEAN","LEARN","LEAST","LEAVE","LEFT","LEG","LEGAL","LEGISLATION","LENGTH","LESS","LET","LETTER","LEVEL","LIABILITY","LIBERAL","LIBRARY","LIE","LIFE","LIFT","LIGHT","LIKE","LIKELY","LIMIT","LIMITED","LINE","LINK","LIP","LIST","LISTEN","LITERATURE","LITTLE","LIVE","LIVING","LOAN","LOCAL","LOCATION","LONG","LOOK","LORD","LOSE","LOSS","LOT","LOVE","LOVELY","LOW","LUNCH","MACHINE","MAGAZINE","MAIN","MAINLY","MAINTAIN","MAJOR","MAJORITY","MAKE","MALE","MAN","MANAGE","MANAGEMENT","MANAGER","MANNER","MANY","MAP","MARK","MARKET","MARRIAGE","MARRIED","MARRY","MASS","MASTER","MATCH","MATERIAL","MATTER","MAY","MAYBE","ME","MEAL","MEAN","MEANING","MEANS","MEANWHILE","MEASURE","MECHANISM","MEDIA","MEDICAL","MEET","MEETING","MEMBER","MEMBERSHIP","MEMORY","MENTAL","MENTION","MERELY","MESSAGE","METAL","METHOD","MIDDLE","MIGHT","MILE","MILITARY","MILK","MIND","MINE","MINISTER","MINISTRY","MINUTE","MISS","MISTAKE","MODEL","MODERN","MODULE","MOMENT","MONEY","MONTH","MORE","MORNING","MOST","MOTHER","MOTION","MOTOR","MOUNTAIN","MOUTH","MOVE","MOVEMENT","MUCH","MURDER","MUSEUM","MUSIC","MUST","MY","MYSELF","NAME","NARROW","NATION","NATIONAL","NATURAL","NATURE","NEAR","NEARLY","NECESSARILY","NECESSARY","NECK","NEED","NEGOTIATION","NEIGHBOUR","NEITHER","NETWORK","NEVER","NEVERTHELESS","NEW","NEWS","NEWSPAPER","NEXT","NICE","NIGHT","NO","NOBODY","NOD","NOISE","NONE","NOR","NORMAL","NORMALLY","NORTH","NORTHERN","NOSE","NOT","NOTE","NOTHING","NOTICE","NOTION","NOW","NUCLEAR","NUMBER","NURSE","OBJECT","OBJECTIVE","OBSERVATION","OBSERVE","OBTAIN","OBVIOUS","OBVIOUSLY","OCCASION","OCCUR","ODD","OF","OFF","OFFENCE","OFFER","OFFICE","OFFICER","OFFICIAL","OFTEN","OIL","OKAY","OLD","ON","ONCE","ONE","ONLY","ONTO","OPEN","OPERATE","OPERATION","OPINION","OPPORTUNITY","OPPOSITION","OPTION","OR","ORDER","ORDINARY","ORGANISATION","ORGANISE","ORGANIZATION","ORIGIN","ORIGINAL","OTHER","OTHERWISE","OUGHT","OUR","OURSELVES","OUT","OUTCOME","OUTPUT","OUTSIDE","OVER","OVERALL","OWN","OWNER","PACKAGE","PAGE","PAIN","PAINT","PAINTING","PAIR","PANEL","PAPER","PARENT","PARK","PARLIAMENT","PART","PARTICULAR","PARTICULARLY","PARTLY","PARTNER","PARTY","PASS","PASSAGE","PAST","PATH","PATIENT","PATTERN","PAY","PAYMENT","PEACE","PENSION","PEOPLE","PER","PERCENT","PERFECT","PERFORM","PERFORMANCE","PERHAPS","PERIOD","PERMANENT","PERSON","PERSONAL","PERSUADE","PHASE","PHONE","PHOTOGRAPH","PHYSICAL","PICK","PICTURE","PIECE","PLACE","PLAN","PLANNING","PLANT","PLASTIC","PLATE","PLAY","PLAYER","PLEASE","PLEASURE","PLENTY","PLUS","POCKET","POINT","POLICE","POLICY","POLITICAL","POLITICS","POOL","POOR","POPULAR","POPULATION","POSITION","POSITIVE","POSSIBILITY","POSSIBLE","POSSIBLY","POST","POTENTIAL","POUND","POWER","POWERFUL","PRACTICAL","PRACTICE","PREFER","PREPARE","PRESENCE","PRESENT","PRESIDENT","PRESS","PRESSURE","PRETTY","PREVENT","PREVIOUS","PREVIOUSLY","PRICE","PRIMARY","PRIME","PRINCIPLE","PRIORITY","PRISON","PRISONER","PRIVATE","PROBABLY","PROBLEM","PROCEDURE","PROCESS","PRODUCE","PRODUCT","PRODUCTION","PROFESSIONAL","PROFIT","PROGRAM","PROGRAMME","PROGRESS","PROJECT","PROMISE","PROMOTE","PROPER","PROPERLY","PROPERTY","PROPORTION","PROPOSE","PROPOSAL","PROSPECT","PROTECT","PROTECTION","PROVE","PROVIDE","PROVIDED","PROVISION","PUB","PUBLIC","PUBLICATION","PUBLISH","PULL","PUPIL","PURPOSE","PUSH","PUT","QUALITY","QUARTER","QUESTION","QUICK","QUICKLY","QUIET","QUITE","RACE","RADIO","RAILWAY","RAIN","RAISE","RANGE","RAPIDLY","RARE","RATE","RATHER","REACH","REACTION","READ","READER","READING","READY","REAL","REALISE","REALITY","REALIZE","REALLY","REASON","REASONABLE","RECALL","RECEIVE","RECENT","RECENTLY","RECOGNISE","RECOGNITION","RECOGNIZE","RECOMMEND","RECORD","RECOVER","RED","REDUCE","REDUCTION","REFER","REFERENCE","REFLECT","REFORM","REFUSE","REGARD","REGION","REGIONAL","REGULAR","REGULATION","REJECT","RELATE","RELATION","RELATIONSHIP","RELATIVE","RELATIVELY","RELEASE","RELEVANT","RELIEF","RELIGION","RELIGIOUS","RELY","REMAIN","REMEMBER","REMIND","REMOVE","REPEAT","REPLACE","REPLY","REPORT","REPRESENT","REPRESENTATION","REPRESENTATIVE","REQUEST","REQUIRE","REQUIREMENT","RESEARCH","RESOURCE","RESPECT","RESPOND","RESPONSE","RESPONSIBILITY","RESPONSIBLE","REST","RESTAURANT","RESULT","RETAIN","RETURN","REVEAL","REVENUE","REVIEW","REVOLUTION","RICH","RIDE","RIGHT","RING","RISE","RISK","RIVER","ROAD","ROCK","ROLE","ROLL","ROOF","ROOM","ROUND","ROUTE","ROW","ROYAL","RULE","RUN","RURAL","SAFE","SAFETY","SALE","SAME","SAMPLE","SATISFY","SAVE","SAY","SCALE","SCENE","SCHEME","SCHOOL","SCIENCE","SCIENTIFIC","SCIENTIST","SCORE","SCREEN","SEA","SEARCH","SEASON","SEAT","SECOND","SECONDARY","SECRETARY","SECTION","SECTOR","SECURE","SECURITY","SEE","SEEK","SEEM","SELECT","SELECTION","SELL","SEND","SENIOR","SENSE","SENTENCE","SEPARATE","SEQUENCE","SERIES","SERIOUS","SERIOUSLY","SERVANT","SERVE","SERVICE","SESSION","SET","SETTLE","SETTLEMENT","SEVERAL","SEVERE","SEX","SEXUAL","SHAKE","SHALL","SHAPE","SHARE","SHE","SHEET","SHIP","SHOE","SHOOT","SHOP","SHORT","SHOT","SHOULD","SHOULDER","SHOUT","SHOW","SHUT","SIDE","SIGHT","SIGN","SIGNAL","SIGNIFICANCE","SIGNIFICANT","SILENCE","SIMILAR","SIMPLE","SIMPLY","SINCE","SING","SINGLE","SIR","SISTER","SIT","SITE","SITUATION","SIZE","SKILL","SKIN","SKY","SLEEP","SLIGHTLY","SLIP","SLOW","SLOWLY","SMALL","SMILE","SO","SOCIAL","SOCIETY","SOFT","SOFTWARE","SOIL","SOLDIER","SOLICITOR","SOLUTION","SOME","SOMEBODY","SOMEONE","SOMETHING","SOMETIMES","SOMEWHAT","SOMEWHERE","SON","SONG","SOON","SORRY","SORT","SOUND","SOURCE","SOUTH","SOUTHERN","SPACE","SPEAK","SPEAKER","SPECIAL","SPECIES","SPECIFIC","SPEECH","SPEED","SPEND","SPIRIT","SPORT","SPOT","SPREAD","SPRING","STAFF","STAGE","STAND","STANDARD","STAR","START","STATE","STATEMENT","STATION","STATUS","STAY","STEAL","STEP","STICK","STILL","STOCK","STONE","STOP","STORE","STORY","STRAIGHT","STRANGE","STRATEGY","STREET","STRENGTH","STRIKE","STRONG","STRONGLY","STRUCTURE","STUDENT","STUDIO","STUDY","STUFF","STYLE","SUBJECT","SUBSTANTIAL","SUCCEED","SUCCESS","SUCCESSFUL","SUCH","SUDDENLY","SUFFER","SUFFICIENT","SUGGEST","SUGGESTION","SUITABLE","SUM","SUMMER","SUN","SUPPLY","SUPPORT","SUPPOSE","SURE","SURELY","SURFACE","SURPRISE","SURROUND","SURVEY","SURVIVE","SWITCH","SYSTEM","TABLE","TAKE","TALK","TALL","TAPE","TARGET","TASK","TAX","TEA","TEACH","TEACHER","TEACHING","TEAM","TEAR","TECHNICAL","TECHNIQUE","TECHNOLOGY","TELEPHONE","TELEVISION","TELL","TEMPERATURE","TEND","TERM","TERMS","TERRIBLE","TEST","TEXT","THAN","THANK","THANKS","THAT","THE","THEATRE","THEIR","THEM","THEME","THEMSELVES","THEN","THEORY","THERE","THEREFORE","THESE","THEY","THIN","THING","THINK","THIS","THOSE","THOUGH","THOUGHT","THREAT","THREATEN","THROUGH","THROUGHOUT","THROW","THUS","TICKET","TIME","TINY","TITLE","TO","TODAY","TOGETHER","TOMORROW","TONE","TONIGHT","TOO","TOOL","TOOTH","TOP","TOTAL","TOTALLY","TOUCH","TOUR","TOWARDS","TOWN","TRACK","TRADE","TRADITION","TRADITIONAL","TRAFFIC","TRAIN","TRAINING","TRANSFER","TRANSPORT","TRAVEL","TREAT","TREATMENT","TREATY","TREE","TREND","TRIAL","TRIP","TROOP","TROUBLE","TRUE","TRUST","TRUTH","TRY","TURN","TWICE","TYPE","TYPICAL","UNABLE","UNDER","UNDERSTAND","UNDERSTANDING","UNDERTAKE","UNEMPLOYMENT","UNFORTUNATELY","UNION","UNIT","UNITED","UNIVERSITY","UNLESS","UNLIKELY","UNTIL","UP","UPON","UPPER","URBAN","US","USE","USED","USEFUL","USER","USUAL","USUALLY","VALUE","VARIATION","VARIETY","VARIOUS","VARY","VAST","VEHICLE","VERSION","VERY","VIA","VICTIM","VICTORY","VIDEO","VIEW","VILLAGE","VIOLENCE","VISION","VISIT","VISITOR","VITAL","VOICE","VOLUME","VOTE","WAGE","WAIT","WALK","WALL","WANT","WAR","WARM","WARN","WASH","WATCH","WATER","WAVE","WAY","WE","WEAK","WEAPON","WEAR","WEATHER","WEEK","WEEKEND","WEIGHT","WELCOME","WELFARE","WELL","WEST","WESTERN","WHAT","WHATEVER","WHEN","WHERE","WHEREAS","WHETHER","WHICH","WHILE","WHILST","WHITE","WHO","WHOLE","WHOM","WHOSE","WHY","WIDE","WIDELY","WIFE","WILD","WILL","WIN","WIND","WINDOW","WINE","WING","WINNER","WINTER","WISH","WITH","WITHDRAW","WITHIN","WITHOUT","WOMAN","WONDER","WONDERFUL","WOOD","WORD","WORK","WORKER","WORKING","WORKS","WORLD","WORRY","WORTH","WOULD","WRITE","WRITER","WRITING","WRONG","YARD","YEAH","YEAR","YES","YESTERDAY","YET","YOU","YOUNG","YOUR","YOURSELF","YOUTH" \ No newline at end of file diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index 5df516f2f4..f206f59472 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -58,7 +58,4 @@ PRIVATE> ! [ euler067a ] 100 ave-time ! 14 ms run / 0 ms GC ave time - 100 trials -! source-067 [ max-path ] curry 100 ave-time -! 3 ms run / 0 ms GC ave time - 100 trials - MAIN: euler067a diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 99bb3169c4..0910cbcb7b 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -13,6 +13,7 @@ IN: project-euler.common ! collect-consecutive - #8, #11 ! log10 - #25, #134 ! max-path - #18, #67 +! nth-triangle - #12, #42 ! number>digits - #16, #20, #30, #34 ! pandigital? - #32, #38 ! propagate-all - #18, #67 @@ -77,6 +78,9 @@ PRIVATE> : number>digits ( n -- seq ) number>string string>digits ; +: nth-triangle ( n -- n ) + dup 1+ * 2 / ; + : pandigital? ( n -- ? ) number>string natural-sort "123456789" = ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 3433fe7154..226c47b0a3 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,8 +12,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.048 project-euler.067 project-euler.075 - project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.042 project-euler.048 project-euler.067 + project-euler.075 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler Date: Sun, 3 Feb 2008 22:11:31 -0500 Subject: [PATCH 06/42] Solution to Project Euler problem 52 --- extra/project-euler/052/052.factor | 50 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 6 +-- 2 files changed, 53 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/052/052.factor diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor new file mode 100644 index 0000000000..3f6487fb3e --- /dev/null +++ b/extra/project-euler/052/052.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math project-euler.common sequences sorting ; +IN: project-euler.052 + +! http://projecteuler.net/index.php?section=problems&id=52 + +! DESCRIPTION +! ----------- + +! It can be seen that the number, 125874, and its double, 251748, contain +! exactly the same digits, but in a different order. + +! Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, +! contain the same digits. + + +! SOLUTION +! -------- + +! Analysis shows the number must be odd, divisible by 3, and larger than 123456 + +digits natural-sort ] map all-equal? ; + +: candidate? ( n -- ? ) + { [ dup odd? ] [ dup 3 mod zero? ] } && nip ; + +: next-all-same ( x n -- n ) + dup candidate? [ + 2dup swap map-nx all-same-digits? + [ nip ] [ 1+ next-all-same ] if + ] [ + 1+ next-all-same + ] if ; + +PRIVATE> + +: euler052 ( -- answer ) + 6 123456 next-all-same ; + +! [ euler052 ] 100 ave-time +! 403 ms run / 7 ms GC ave time - 100 trials + +MAIN: euler052 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 226c47b0a3..2f8a3184bb 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,9 +12,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.042 project-euler.048 project-euler.067 - project-euler.075 project-euler.134 project-euler.169 project-euler.173 - project-euler.175 ; + project-euler.041 project-euler.042 project-euler.048 project-euler.052 + project-euler.067 project-euler.075 project-euler.134 project-euler.169 + project-euler.173 project-euler.175 ; IN: project-euler Date: Mon, 4 Feb 2008 01:40:47 -0500 Subject: [PATCH 07/42] Solution to Project Euler problem 97 --- extra/project-euler/097/097.factor | 31 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 4 +-- 2 files changed, 33 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/097/097.factor diff --git a/extra/project-euler/097/097.factor b/extra/project-euler/097/097.factor new file mode 100644 index 0000000000..50e7af563d --- /dev/null +++ b/extra/project-euler/097/097.factor @@ -0,0 +1,31 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: math math.functions ; +IN: project-euler.097 + +! http://projecteuler.net/index.php?section=problems&id=97 + +! DESCRIPTION +! ----------- + +! The first known prime found to exceed one million digits was discovered in +! 1999, and is a Mersenne prime of the form 2^6972593 − 1; it contains exactly +! 2,098,960 digits. Subsequently other Mersenne primes, of the form 2p − 1, +! have been found which contain more digits. + +! However, in 2004 there was found a massive non-Mersenne prime which contains +! 2,357,207 digits: 28433 * 2^7830457 + 1. + +! Find the last ten digits of this prime number. + + +! SOLUTION +! -------- + +: euler097 ( -- answer ) + 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ; + +! [ euler097 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler097 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 2f8a3184bb..0be0b456ad 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -13,8 +13,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.048 project-euler.052 - project-euler.067 project-euler.075 project-euler.134 project-euler.169 - project-euler.173 project-euler.175 ; + project-euler.067 project-euler.075 project-euler.097 project-euler.134 + project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Mon, 4 Feb 2008 01:49:31 -0500 Subject: [PATCH 08/42] Add missing dependency for Project Euler 42 --- extra/project-euler/042/042.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor index 3d5f271374..95b3062e95 100644 --- a/extra/project-euler/042/042.factor +++ b/extra/project-euler/042/042.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: ascii combinators.lib io.files kernel math namespaces +USING: ascii combinators.lib io.files kernel math math.functions namespaces project-euler.common sequences splitting ; IN: project-euler.042 From c68e70877d47bd1239f6a1402edc767a7b6a3dfe Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 5 Feb 2008 16:42:50 -0500 Subject: [PATCH 09/42] Solution to Project Euler problem 43 --- extra/project-euler/043/043.factor | 97 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 6 +- 2 files changed, 100 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/043/043.factor diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor new file mode 100644 index 0000000000..abe455e273 --- /dev/null +++ b/extra/project-euler/043/043.factor @@ -0,0 +1,97 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib hashtables kernel math math.combinatorics math.parser + math.ranges project-euler.common sequences sorting ; +IN: project-euler.043 + +! http://projecteuler.net/index.php?section=problems&id=43 + +! DESCRIPTION +! ----------- + +! The number, 1406357289, is a 0 to 9 pandigital number because it is made up +! of each of the digits 0 to 9 in some order, but it also has a rather +! interesting sub-string divisibility property. + +! Let d1 be the 1st digit, d2 be the 2nd digit, and so on. In this way, we note +! the following: + +! * d2d3d4 = 406 is divisible by 2 +! * d3d4d5 = 063 is divisible by 3 +! * d4d5d6 = 635 is divisible by 5 +! * d5d6d7 = 357 is divisible by 7 +! * d6d7d8 = 572 is divisible by 11 +! * d7d8d9 = 728 is divisible by 13 +! * d8d9d10 = 289 is divisible by 17 + +! Find the sum of all 0 to 9 pandigital numbers with this property. + + +! SOLUTION +! -------- + +! Brute force generating all the pandigitals then checking 3-digit divisiblity +! properties...this is very slow! + +integer swap mod zero? ; + +: interesting? ( seq -- ? ) + { + [ 17 8 pick subseq-divisible? ] + [ 13 7 pick subseq-divisible? ] + [ 11 6 pick subseq-divisible? ] + [ 7 5 pick subseq-divisible? ] + [ 5 4 pick subseq-divisible? ] + [ 3 3 pick subseq-divisible? ] + [ 2 2 pick subseq-divisible? ] + } && nip ; + +PRIVATE> + +: euler043 ( -- answer ) + 1234567890 number>digits all-permutations + [ interesting? ] subset [ 10 swap digits>integer ] map sum ; + +! [ euler043 ] time +! 125196 ms run / 19548 ms GC time + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Build the number from right to left, generating the next 3-digits according +! to the divisiblity rules and combining them with the previous digits if they +! overlap and still have all unique digits. When done with that, add whatever +! missing digit is needed to make the number pandigital. + + [ number>digits 3 0 pad-left ] map [ all-unique? ] subset ; + +: overlap? ( seq -- ? ) + dup first 2 tail* swap second 2 head = ; + +: clean ( seq -- seq ) + [ unclip 1 head add* concat ] map [ all-unique? ] subset ; + +: add-missing-digit ( seq -- seq ) + dup natural-sort 10 seq-diff first add* ; + +: interesting-pandigitals ( -- seq ) + 17 candidates { 13 11 7 5 3 2 } [ + candidates swap cartesian-product [ overlap? ] subset clean + ] each [ add-missing-digit ] map ; + +PRIVATE> + +: euler043a ( -- answer ) + interesting-pandigitals [ 10 swap digits>integer ] sigma ; + +! [ euler043a ] 100 ave-time +! 19 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler043a diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 0be0b456ad..ef28cf8778 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,9 +12,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.042 project-euler.048 project-euler.052 - project-euler.067 project-euler.075 project-euler.097 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.042 project-euler.043 project-euler.048 + project-euler.052 project-euler.067 project-euler.075 project-euler.097 + project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Tue, 5 Feb 2008 18:28:05 -0600 Subject: [PATCH 10/42] builder: update target --- extra/builder/builder.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 3216105d47..832b89a7dc 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -33,7 +33,12 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; +! : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; + +: target ( -- target ) + { { [ os "windows" = ] [ "windows-nt-x86-32" ] } + { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } + cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From e3e2cc7e0d647b628b245372a7c178ed492f42c4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 5 Feb 2008 23:09:33 -0600 Subject: [PATCH 11/42] Add builder.load-everything --- extra/builder/builder.factor | 57 ++++++++++++------- .../load-everything/load-everything.factor | 23 ++++++++ 2 files changed, 58 insertions(+), 22 deletions(-) create mode 100644 extra/builder/load-everything/load-everything.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 832b89a7dc..375023cb5e 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -33,19 +33,19 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; +: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; -: target ( -- target ) - { { [ os "windows" = ] [ "windows-nt-x86-32" ] } - { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } - cond ; +! : target ( -- target ) +! { { [ os "windows" = ] [ "windows-nt-x86-32" ] } +! { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } +! cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : factor-binary ( -- name ) os { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } - { "windows" [ "./factor-nt.exe" ] } + { "winnt" [ "./factor-nt.exe" ] } [ drop "./factor" ] } case ; @@ -61,7 +61,13 @@ VAR: stamp "/builds/factor" cd - { "git" "pull" "--no-summary" "git://factorcode.org/git/factor.git" } + { + "git" + "pull" + "--no-summary" + "git://factorcode.org/git/factor.git" + "master" + } run-process process-status 0 = [ ] @@ -74,7 +80,7 @@ VAR: stamp "/builds/" stamp> append make-directory "/builds/" stamp> append cd - { "git" "clone" "/builds/factor" } run-process drop + { "git" "clone" "../factor" } run-process drop "factor" cd @@ -121,20 +127,27 @@ VAR: stamp "builder: bootstrap" throw ] if - `{ - { +arguments+ - { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } - { +stdout+ "../load-everything-log" } - { +stderr+ +stdout+ } - } - >hashtable [ run-process process-status ] benchmark nip - "../load-everything-time" [ . ] with-stream - 0 = - [ ] - [ - "builder: load-everything" "../load-everything-log" email-file - "builder: load-everything" throw - ] if ; +! `{ +! { +arguments+ +! { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } +! { +stdout+ "../load-everything-log" } +! { +stderr+ +stdout+ } +! } +! >hashtable [ run-process process-status ] benchmark nip +! "../load-everything-time" [ . ] with-stream +! 0 = +! [ ] +! [ +! "builder: load-everything" "../load-everything-log" email-file +! "builder: load-everything" throw +! ] if ; + + `{ ,[ factor-binary ] "-run=builder.load-everything" } run-process drop + "../load-everything-log" exists? + [ "builder: load-everything" "../load-everything-log" email-file ] + when + + ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/load-everything/load-everything.factor b/extra/builder/load-everything/load-everything.factor new file mode 100644 index 0000000000..12007f214b --- /dev/null +++ b/extra/builder/load-everything/load-everything.factor @@ -0,0 +1,23 @@ + +USING: kernel continuations io io.files prettyprint vocabs.loader + tools.time tools.browser ; + +IN: builder.load-everything + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: runtime ( quot -- time ) benchmark nip ; + +: log-runtime ( quot file -- ) + >r runtime r> [ . ] with-stream ; + +: log-object ( object file -- ) [ . ] with-stream ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: do-load-everything ( -- ) + [ [ load-everything ] catch ] "../load-everything-time" log-runtime + [ require-all-error-vocabs "../load-everything-log" log-object ] + when ; + +MAIN: do-load-everything \ No newline at end of file From d27ae067089d7d196cc9634fd87940e0717ca236 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 Feb 2008 00:53:18 -0500 Subject: [PATCH 12/42] Solution to Project Euler problem 44 --- extra/project-euler/044/044.factor | 50 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 7 ++-- 2 files changed, 54 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/044/044.factor diff --git a/extra/project-euler/044/044.factor b/extra/project-euler/044/044.factor new file mode 100644 index 0000000000..6369cb5372 --- /dev/null +++ b/extra/project-euler/044/044.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.ranges project-euler.common sequences ; +IN: project-euler.044 + +! http://projecteuler.net/index.php?section=problems&id=44 + +! DESCRIPTION +! ----------- + +! Pentagonal numbers are generated by the formula, Pn=n(3n−1)/2. The first ten +! pentagonal numbers are: + +! 1, 5, 12, 22, 35, 51, 70, 92, 117, 145, ... + +! It can be seen that P4 + P7 = 22 + 70 = 92 = P8. However, their difference, +! 70 − 22 = 48, is not pentagonal. + +! Find the pair of pentagonal numbers, Pj and Pk, for which their sum and +! difference is pentagonal and D = |Pk − Pj| is minimised; what is the value of D? + + +! SOLUTION +! -------- + +! Brute force using a cartesian product and an arbitrarily chosen limit. + + [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ; + +: sum-and-diff? ( m n -- ? ) + 2dup + -rot - [ pentagonal? ] 2apply and ; + +PRIVATE> + +: euler044 ( -- answer ) + 2500 [1,b] [ nth-pentagonal ] map dup cartesian-product + [ first2 sum-and-diff? ] subset [ first2 - abs ] map infimum ; + +! [ euler044 ] 10 ave-time +! 8924 ms run / 2872 ms GC ave time - 10 trials + +! TODO: this solution is ugly and not very efficient...find a better algorithm + +MAIN: euler044 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index ef28cf8778..36a9069d77 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,9 +12,10 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.042 project-euler.043 project-euler.048 - project-euler.052 project-euler.067 project-euler.075 project-euler.097 - project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.042 project-euler.043 project-euler.044 + project-euler.048 project-euler.052 project-euler.067 project-euler.075 + project-euler.097 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler Date: Wed, 6 Feb 2008 04:26:13 -0600 Subject: [PATCH 13/42] Add builder.test --- extra/builder/builder.factor | 46 +++++++++++++--------------------- extra/builder/test/test.factor | 33 ++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 28 deletions(-) create mode 100644 extra/builder/test/test.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 375023cb5e..2acdbc3294 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -8,6 +8,15 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: runtime ( quot -- time ) benchmark nip ; + +: log-runtime ( quot file -- ) + >r runtime r> [ . ] with-stream ; + +: log-object ( object file -- ) [ . ] with-stream ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : datestamp ( -- string ) now `{ ,[ dup timestamp-year ] ,[ dup timestamp-month ] @@ -35,11 +44,6 @@ SYMBOL: builder-recipients : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; -! : target ( -- target ) -! { { [ os "windows" = ] [ "windows-nt-x86-32" ] } -! { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } -! cond ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : factor-binary ( -- name ) @@ -84,10 +88,8 @@ VAR: stamp "factor" cd - { "git" "show" } - [ readln ] with-stream - " " split second - "../git-id" [ print ] with-stream + { "git" "show" } [ readln ] with-stream " " split second + "../git-id" log-object { "make" "clean" } run-process drop @@ -117,9 +119,7 @@ VAR: stamp { +stdout+ "../boot-log" } { +stderr+ +stdout+ } } - >hashtable - [ run-process process-status ] - benchmark nip "../boot-time" [ . ] with-stream + >hashtable [ run-process ] "../boot-time" log-runtime process-status 0 = [ ] [ @@ -127,26 +127,16 @@ VAR: stamp "builder: bootstrap" throw ] if -! `{ -! { +arguments+ -! { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } -! { +stdout+ "../load-everything-log" } -! { +stderr+ +stdout+ } -! } -! >hashtable [ run-process process-status ] benchmark nip -! "../load-everything-time" [ . ] with-stream -! 0 = -! [ ] -! [ -! "builder: load-everything" "../load-everything-log" email-file -! "builder: load-everything" throw -! ] if ; - - `{ ,[ factor-binary ] "-run=builder.load-everything" } run-process drop + `{ ,[ factor-binary ] "-run=builder.test" } run-process drop + "../load-everything-log" exists? [ "builder: load-everything" "../load-everything-log" email-file ] when + "../failing-tests" exists? + [ "builder: failing tests" "../failing-tests" email-file ] + when + ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor new file mode 100644 index 0000000000..ed75e99527 --- /dev/null +++ b/extra/builder/test/test.factor @@ -0,0 +1,33 @@ + +USING: kernel sequences assocs builder continuations vocabs vocabs.loader + io + io.files + tools.browser + tools.test ; + +IN: builder.test + +: do-load ( -- ) + [ [ load-everything ] catch ] "../load-everything-time" log-runtime + [ require-all-error-vocabs "../load-everything-log" log-object ] + when* ; + +: do-tests ( -- ) + "" child-vocabs + [ vocab-source-loaded? ] subset + [ vocab-tests-path ] map + [ dup [ ?resource-path exists? ] when ] subset + [ dup run-test ] { } map>assoc + [ second empty? not ] subset + dup empty? + [ drop ] + [ + "../failing-tests" + [ [ nl failures. ] assoc-each ] + with-stream + ] + if ; + +: do-all ( -- ) do-load do-tests ; + +MAIN: do-all \ No newline at end of file From a5c69dae631af981fdc598828c44ecdc12423bbe Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Feb 2008 06:10:55 -0600 Subject: [PATCH 14/42] update builder.test --- .../load-everything/load-everything.factor | 23 ------------------- extra/builder/test/test.factor | 9 +++++--- 2 files changed, 6 insertions(+), 26 deletions(-) delete mode 100644 extra/builder/load-everything/load-everything.factor diff --git a/extra/builder/load-everything/load-everything.factor b/extra/builder/load-everything/load-everything.factor deleted file mode 100644 index 12007f214b..0000000000 --- a/extra/builder/load-everything/load-everything.factor +++ /dev/null @@ -1,23 +0,0 @@ - -USING: kernel continuations io io.files prettyprint vocabs.loader - tools.time tools.browser ; - -IN: builder.load-everything - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: runtime ( quot -- time ) benchmark nip ; - -: log-runtime ( quot file -- ) - >r runtime r> [ . ] with-stream ; - -: log-object ( object file -- ) [ . ] with-stream ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: do-load-everything ( -- ) - [ [ load-everything ] catch ] "../load-everything-time" log-runtime - [ require-all-error-vocabs "../load-everything-log" log-object ] - when ; - -MAIN: do-load-everything \ No newline at end of file diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index ed75e99527..fb9c62e2aa 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -8,9 +8,12 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test : do-load ( -- ) - [ [ load-everything ] catch ] "../load-everything-time" log-runtime - [ require-all-error-vocabs "../load-everything-log" log-object ] - when* ; + [ + [ load-everything ] + [ require-all-error-vocabs "../load-everything-log" log-object ] + recover + ] + "../load-everything-time" log-runtime ; : do-tests ( -- ) "" child-vocabs From 2a417f4a9c79f02fa1af909337c2e669910cf42b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 Feb 2008 19:36:53 -0600 Subject: [PATCH 15/42] add with-file-in with-file-out with-file-appender --- core/io/files/files.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 9a99090699..8c9bd8f2e9 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -169,3 +169,12 @@ PRIVATE> : file-contents ( path -- str ) dup swap file-length [ stream-copy ] keep >string ; + +: with-file-in ( path quot -- ) + >r r> with-stream ; inline + +: with-file-out ( path quot -- ) + >r r> with-stream ; inline + +: with-file-appender ( path quot -- ) + >r r> with-stream ; inline From 99411495c2eaa5e4a6a7501cf8c3dbed2bed80b7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 Feb 2008 19:49:07 -0600 Subject: [PATCH 16/42] add http-update to work around firewalls --- misc/factor.sh | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 26ebd04531..f0eb232821 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -200,6 +200,12 @@ git_pull_factorcode() { check_ret git } +http_git_pull_factorcode() { + echo "Updating the git repository from factorcode.org..." + git pull http://factorcode.org/git/factor.git master + check_ret git +} + cd_factor() { cd factor check_ret cd @@ -271,6 +277,7 @@ install() { bootstrap } + update() { get_config_info git_pull_factorcode @@ -278,6 +285,13 @@ update() { make_factor } +http_update() { + get_config_info + http_git_pull_factorcode + make_clean + make_factor +} + update_bootstrap() { delete_boot_images get_boot_image @@ -310,6 +324,7 @@ case "$1" in self-update) update; make_boot_image; bootstrap;; quick-update) update; refresh_image ;; update) update; update_bootstrap ;; + http-update) http_update; update_bootstrap ;; bootstrap) get_config_info; bootstrap ;; wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;; *) usage ;; From 5f997fe2c7c5c071a0f7975170daa6d9f4256aef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 20:04:09 -0600 Subject: [PATCH 17/42] Make extra/unix load on Windows --- extra/unix/unix.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index d32fc25eab..59141c1940 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -220,7 +220,8 @@ FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { - { [ linux? ] [ "unix.linux" ] } - { [ bsd? ] [ "unix.bsd" ] } - { [ solaris? ] [ "unix.solaris" ] } -} cond require + { [ linux? ] [ "unix.linux" require ] } + { [ bsd? ] [ "unix.bsd" require ] } + { [ solaris? ] [ "unix.solaris" require ] } + { [ t ] [ ] } +} cond From f3c8bd266b0300a920fd8896372177504aa6984c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 20:05:03 -0600 Subject: [PATCH 18/42] Improved syntax for ratios --- core/math/parser/parser-tests.factor | 10 --- core/math/parser/parser.factor | 89 ++++++++++++++++++--------- extra/math/ratios/ratios-tests.factor | 5 ++ extra/math/ratios/ratios.factor | 1 + 4 files changed, 66 insertions(+), 39 deletions(-) diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 7c30012a19..226e47090a 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -95,16 +95,6 @@ unit-test [ f ] [ "\0." string>number ] unit-test -! [ t ] [ -! { "1.0/0.0" "-1.0/0.0" "0.0/0.0" } -! [ dup string>number number>string = ] all? -! ] unit-test -! -! [ t ] [ -! { 1.0/0.0 -1.0/0.0 0.0/0.0 } -! [ dup number>string string>number = ] all? -! ] unit-test - [ 1 1 >base ] must-fail [ 1 0 >base ] must-fail [ 1 -1 >base ] must-fail diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 7f0404812d..73b4a725d2 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -4,12 +4,6 @@ USING: kernel math.private namespaces sequences strings arrays combinators splitting math assocs ; IN: math.parser -DEFER: base> - -: string>ratio ( str radix -- a/b ) - >r "/" split1 r> tuck base> >r base> r> - 2dup and [ / ] [ 2drop f ] if ; - : digit> ( ch -- n ) H{ { CHAR: 0 0 } @@ -36,30 +30,54 @@ DEFER: base> { CHAR: f 15 } } at ; -: digits>integer ( radix seq -- n ) - 0 rot [ swapd * + ] curry reduce ; - -: valid-digits? ( radix seq -- ? ) - { - { [ dup empty? ] [ 2drop f ] } - { [ f over memq? ] [ 2drop f ] } - { [ t ] [ swap [ < ] curry all? ] } - } cond ; - : string>digits ( str -- digits ) [ digit> ] { } map-as ; -: string>integer ( str radix -- n/f ) - swap "-" ?head >r - string>digits 2dup valid-digits? - [ digits>integer r> [ neg ] when ] [ r> 3drop f ] if ; +DEFER: base> + +) ( str -- n ) radix get base> ; + +: whole-part ( str -- m n ) + "+" split1 >r (base>) r> + dup [ (base>) ] [ drop 0 swap ] if ; + +: string>ratio ( str -- a/b ) + "/" split1 (base>) >r whole-part r> + 3dup and and [ / + ] [ 3drop f ] if ; + +: digits>integer ( seq -- n ) + 0 radix get [ swapd * + ] curry reduce ; + +: valid-digits? ( seq -- ? ) + { + { [ dup empty? ] [ drop f ] } + { [ f over memq? ] [ drop f ] } + { [ t ] [ radix get [ < ] curry all? ] } + } cond ; + +: string>integer ( str -- n/f ) + string>digits dup valid-digits? + [ digits>integer ] [ drop f ] if ; + +PRIVATE> : base> ( str radix -- n/f ) - { - { [ CHAR: / pick member? ] [ string>ratio ] } - { [ CHAR: . pick member? ] [ drop string>float ] } - { [ t ] [ string>integer ] } - } cond ; + [ + "-" ?head >r + { + { [ CHAR: / over member? ] [ string>ratio ] } + { [ CHAR: . over member? ] [ string>float ] } + { [ t ] [ string>integer ] } + } cond + r> [ dup [ neg ] when ] when + ] with-radix ; : string>number ( str -- n/f ) 10 base> ; : bin> ( str -- n/f ) 2 base> ; @@ -74,8 +92,16 @@ DEFER: base> dup >r /mod >digit , dup 0 > [ r> integer, ] [ r> 2drop ] if ; +PRIVATE> + GENERIC# >base 1 ( n radix -- str ) +base) ( n -- str ) radix get >base ; + +PRIVATE> + M: integer >base [ over 0 < [ @@ -87,10 +113,15 @@ M: integer >base M: ratio >base [ - over numerator over >base % - CHAR: / , - swap denominator swap >base % - ] "" make ; + [ + dup 0 < [ "-" % neg ] when + 1 /mod + >r dup zero? [ drop ] [ (>base) % "+" % ] if r> + dup numerator (>base) % + "/" % + denominator (>base) % + ] "" make + ] with-radix ; : fix-float ( str -- newstr ) { diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index 79b0b21d28..858a7b0544 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -105,3 +105,8 @@ unit-test [ "33/100" ] [ "66/200" string>number number>string ] unit-test + +[ 3 ] [ "1+1/2" string>number 2 * ] unit-test +[ -3 ] [ "-1+1/2" string>number 2 * ] unit-test +[ "2+1/7" ] [ 1 7 / 2 + number>string ] unit-test +[ "1/8" ] [ 1 8 / number>string ] unit-test diff --git a/extra/math/ratios/ratios.factor b/extra/math/ratios/ratios.factor index 954fd8dd20..5d07bd046f 100755 --- a/extra/math/ratios/ratios.factor +++ b/extra/math/ratios/ratios.factor @@ -48,3 +48,4 @@ M: ratio * 2>fraction * >r * r> / ; M: ratio / scale / ; M: ratio /i scale /i ; M: ratio mod 2dup >r >r /i r> r> rot * - ; +M: ratio /mod [ /i ] 2keep mod ; From 01b1ba0f88836a6543b8b17a8cb83ae0f0cc4c23 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Feb 2008 20:05:52 -0600 Subject: [PATCH 19/42] Temporarily use onigirihouse as the primary --- extra/builder/builder.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 2acdbc3294..5bfd5e01cf 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -69,7 +69,8 @@ VAR: stamp "git" "pull" "--no-summary" - "git://factorcode.org/git/factor.git" + ! "git://factorcode.org/git/factor.git" + "http://dharmatech.onigirihouse.com/factor.git" "master" } run-process process-status From 7534d84d2769fa7d83a78dfa9ec00bca79db38b5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 21:15:33 -0600 Subject: [PATCH 20/42] Refactor tools.test --- extra/tools/test/test.factor | 41 +++++++++++++++++++++--------------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 9590f32539..d761df35d2 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -61,35 +61,42 @@ M: expected-error summary dup first print-error "Traceback" swap third write-object ; -: failures. ( path failures -- ) - "Failing tests in " write swap . - [ nl failure. nl ] each ; - -: run-tests ( seq -- ) - dup empty? [ drop "==== NOTHING TO TEST" print ] [ - [ dup run-test ] { } map>assoc - [ second empty? not ] subset +: failures. ( assoc -- ) + dup [ nl dup empty? [ drop "==== ALL TESTS PASSED" print ] [ "==== FAILING TESTS:" print - [ nl failures. ] assoc-each + [ + nl + "Failing tests in " write swap . + [ nl failure. nl ] each + ] assoc-each ] if + ] [ + drop "==== NOTHING TO TEST" print ] if ; -: run-vocab-tests ( vocabs -- ) - [ vocab-tests-path ] map - [ dup [ ?resource-path exists? ] when ] subset - run-tests ; +: run-vocab-tests ( vocabs -- failures ) + dup empty? [ f ] [ + [ dup run-test ] { } map>assoc + [ second empty? not ] subset + ] if ; -: test ( prefix -- ) +: run-tests ( prefix -- failures ) child-vocabs [ vocab-source-loaded? ] subset + [ vocab-tests-path ] map + [ dup [ ?resource-path exists? ] when ] subset run-vocab-tests ; -: test-all ( -- ) "" test ; +: test ( prefix -- ) + run-tests failures. ; -: test-changes ( -- ) - "" to-refresh dupd do-refresh run-vocab-tests ; +: run-all-tests ( prefix -- failures ) + "" run-tests ; + +: test-all ( -- ) + run-all-tests failures. ; From 2541c62e291ad04de93fadbac7514820bcae657c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 21:15:47 -0600 Subject: [PATCH 21/42] Fix code for math.parser changes --- core/math/parser/parser.factor | 8 ++++---- core/syntax/syntax-docs.factor | 4 +++- extra/json/reader/reader.factor | 2 +- extra/math/ratios/ratios-docs.factor | 1 + extra/math/text/english/english.factor | 2 +- extra/parser-combinators/simple/simple.factor | 2 +- extra/peg/peg.factor | 2 +- extra/project-euler/024/024.factor | 2 +- extra/project-euler/032/032.factor | 10 +++++----- extra/project-euler/035/035.factor | 2 +- extra/project-euler/037/037.factor | 2 +- extra/project-euler/038/038.factor | 2 +- extra/project-euler/040/040.factor | 2 +- extra/random-tester/safe-words/safe-words.factor | 2 +- 14 files changed, 23 insertions(+), 20 deletions(-) mode change 100644 => 100755 extra/json/reader/reader.factor mode change 100644 => 100755 extra/math/text/english/english.factor mode change 100644 => 100755 extra/peg/peg.factor mode change 100644 => 100755 extra/project-euler/024/024.factor mode change 100644 => 100755 extra/project-euler/032/032.factor mode change 100644 => 100755 extra/project-euler/035/035.factor mode change 100644 => 100755 extra/project-euler/037/037.factor mode change 100644 => 100755 extra/project-euler/038/038.factor mode change 100644 => 100755 extra/project-euler/040/040.factor mode change 100644 => 100755 extra/random-tester/safe-words/safe-words.factor diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 73b4a725d2..64ce296a0b 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -33,6 +33,9 @@ IN: math.parser : string>digits ( str -- digits ) [ digit> ] { } map-as ; +: digits>integer ( seq radix -- n ) + 0 swap [ swapd * + ] curry reduce ; + DEFER: base> ) >r whole-part r> 3dup and and [ / + ] [ 3drop f ] if ; -: digits>integer ( seq -- n ) - 0 radix get [ swapd * + ] curry reduce ; - : valid-digits? ( seq -- ? ) { { [ dup empty? ] [ drop f ] } @@ -64,7 +64,7 @@ SYMBOL: radix : string>integer ( str -- n/f ) string>digits dup valid-digits? - [ digits>integer ] [ drop f ] if ; + [ radix get digits>integer ] [ drop f ] if ; PRIVATE> diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 2e5b41cd8d..9ccfd2efcd 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -47,11 +47,13 @@ ARTICLE: "syntax-integers" "Integer syntax" "More information on integers can be found in " { $link "integers" } "." ; ARTICLE: "syntax-ratios" "Ratio syntax" -"The printed representation of a ratio is a pair of integers separated by a slash (/). No intermediate whitespace is permitted. Either integer may be signed, however the ratio will be normalized into a form where the denominator is positive and the greatest common divisor of the two terms is 1." +"The printed representation of a ratio is a pair of integers separated by a slash (/), prefixed by an optional whole number part followed by a plus (+). No intermediate whitespace is permitted. Here are some examples:" { $code "75/33" "1/10" "-5/-6" + "1+1/3" + "-10+1/7" } "More information on ratios can be found in " { $link "rationals" } ; diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor old mode 100644 new mode 100755 index 105989ab93..b136012433 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -104,7 +104,7 @@ LAZY: 'digit1-9' ( -- parser ) LAZY: 'digit0-9' ( -- parser ) [ digit? ] satisfy [ digit> ] <@ ; -: decimal>integer ( seq -- num ) 10 swap digits>integer ; +: decimal>integer ( seq -- num ) 10 digits>integer ; LAZY: 'int' ( -- parser ) 'zero' diff --git a/extra/math/ratios/ratios-docs.factor b/extra/math/ratios/ratios-docs.factor index d996acaf1f..b780a7c322 100755 --- a/extra/math/ratios/ratios-docs.factor +++ b/extra/math/ratios/ratios-docs.factor @@ -7,6 +7,7 @@ ARTICLE: "rationals" "Rational numbers" "When we add, subtract or multiply any two integers, the result is always an integer. However, dividing a numerator by a denominator that is not an integral divisor of the denominator yields a ratio:" { $example "1210 11 / ." "110" } { $example "100 330 / ." "10/33" } +{ $example "14 10 / ." "1+2/5" } "Ratios are printed and can be input literally in the form above. Ratios are always reduced to lowest terms by factoring out the greatest common divisor of the numerator and denominator. A ratio with a denominator of 1 becomes an integer. Division with a denominator of 0 throws an error." $nl "Ratios behave just like any other number -- all numerical operations work as you would expect." diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor old mode 100644 new mode 100755 index 645d7e2054..b77ac725ab --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -33,7 +33,7 @@ SYMBOL: and-needed? : 3digit-groups ( n -- seq ) number>string 3 - [ reverse 10 string>integer ] map ; + [ reverse string>number ] map ; : hundreds-place ( n -- str ) 100 /mod swap dup zero? [ diff --git a/extra/parser-combinators/simple/simple.factor b/extra/parser-combinators/simple/simple.factor index 763f823348..745442610c 100755 --- a/extra/parser-combinators/simple/simple.factor +++ b/extra/parser-combinators/simple/simple.factor @@ -8,7 +8,7 @@ IN: parser-combinators.simple [ digit? ] satisfy [ digit> ] <@ ; : 'integer' ( -- parser ) - 'digit' [ 10 swap digits>integer ] <@ ; + 'digit' [ 10 digits>integer ] <@ ; : 'string' ( -- parser ) [ CHAR: " = ] satisfy diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor old mode 100644 new mode 100755 index 41df8735e5..59a8b63c14 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -343,7 +343,7 @@ MEMO: 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] action ; MEMO: 'integer' ( -- parser ) - 'digit' repeat1 [ 10 swap digits>integer ] action ; + 'digit' repeat1 [ 10 digits>integer ] action ; MEMO: 'string' ( -- parser ) [ diff --git a/extra/project-euler/024/024.factor b/extra/project-euler/024/024.factor old mode 100644 new mode 100755 index c795fc0169..0cc0c39e07 --- a/extra/project-euler/024/024.factor +++ b/extra/project-euler/024/024.factor @@ -23,7 +23,7 @@ IN: project-euler.024 ! -------- : euler024 ( -- answer ) - 999999 10 permutation 10 swap digits>integer ; + 999999 10 permutation 10 digits>integer ; ! [ euler024 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor old mode 100644 new mode 100755 index 2baa6f8714..b8b0758974 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -27,21 +27,21 @@ IN: project-euler.032 integer ] map ; + 9 factorial [ 9 permutation [ 1+ ] map 10 digits>integer ] map ; : 1and4 ( n -- ? ) number>string 1 cut-slice 4 cut-slice - [ 10 string>integer ] 3apply [ * ] dip = ; + [ string>number ] 3apply [ * ] dip = ; : 2and3 ( n -- ? ) number>string 2 cut-slice 3 cut-slice - [ 10 string>integer ] 3apply [ * ] dip = ; + [ string>number ] 3apply [ * ] dip = ; : valid? ( n -- ? ) dup 1and4 swap 2and3 or ; : products ( seq -- m ) - [ number>string 4 tail* 10 string>integer ] map ; + [ number>string 4 tail* string>number ] map ; PRIVATE> @@ -65,7 +65,7 @@ PRIVATE> ! multiplicand/multiplier/product : mmp ( pair -- n ) - first2 2dup * [ number>string ] 3apply 3append 10 string>integer ; + first2 2dup * [ number>string ] 3apply 3append string>number ; PRIVATE> diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor old mode 100644 new mode 100755 index 867bbc44ac..29172111c1 --- a/extra/project-euler/035/035.factor +++ b/extra/project-euler/035/035.factor @@ -38,7 +38,7 @@ IN: project-euler.035 : (circular?) ( seq n -- ? ) dup 0 > [ - 2dup rotate 10 swap digits>integer + 2dup rotate 10 digits>integer prime? [ 1- (circular?) ] [ 2drop f ] if ] [ 2drop t diff --git a/extra/project-euler/037/037.factor b/extra/project-euler/037/037.factor old mode 100644 new mode 100755 index f2d5d17c4d..66b1665037 --- a/extra/project-euler/037/037.factor +++ b/extra/project-euler/037/037.factor @@ -32,7 +32,7 @@ IN: project-euler.037 ] if ; : reverse-digits ( n -- m ) - number>string reverse 10 string>integer ; + number>string reverse string>number ; : l-trunc? ( n -- ? ) reverse-digits 10 /i reverse-digits dup 0 > [ diff --git a/extra/project-euler/038/038.factor b/extra/project-euler/038/038.factor old mode 100644 new mode 100755 index cbe6f2363c..2369db25fb --- a/extra/project-euler/038/038.factor +++ b/extra/project-euler/038/038.factor @@ -36,7 +36,7 @@ IN: project-euler.038 : (concat-product) ( accum n multiplier -- m ) pick length 8 > [ - 2drop 10 swap digits>integer + 2drop 10 digits>integer ] [ [ * number>digits over push-all ] 2keep 1+ (concat-product) ] if ; diff --git a/extra/project-euler/040/040.factor b/extra/project-euler/040/040.factor old mode 100644 new mode 100755 index 8984559265..e2df1df2c9 --- a/extra/project-euler/040/040.factor +++ b/extra/project-euler/040/040.factor @@ -37,7 +37,7 @@ IN: project-euler.040 SBUF" " clone 1 -rot (concat-upto) ; : nth-integer ( n str -- m ) - [ 1- ] dip nth 1string 10 string>integer ; + [ 1- ] dip nth 1string string>number ; PRIVATE> diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor old mode 100644 new mode 100755 index 9bc87a9c5a..ab528786bb --- a/extra/random-tester/safe-words/safe-words.factor +++ b/extra/random-tester/safe-words/safe-words.factor @@ -16,7 +16,7 @@ IN: random-tester.safe-words array? integer? complex? value-ref? ref? key-ref? interval? number? wrapper? tuple? - [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? valid-digits? zero? assoc? curry? vector? callstack? ! clear 3.14 [ assoc? ] compile-1 + [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? zero? assoc? curry? vector? callstack? ! clear 3.14 [ assoc? ] compile-1 2^ not ! arrays resize-array From c1dd7cf855c2f863c44f4d8cb0877e3f854f525c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 21:16:52 -0600 Subject: [PATCH 22/42] Fix Doug's bug --- extra/ui/tools/operations/operations.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index 2375730a81..fbb4338b17 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -188,7 +188,7 @@ source-editor "These commands operate on the Factor word named by the token at the caret position." \ selected-word [ selected-word ] -[ search ] +[ dup search [ ] [ no-word ] ?if ] define-operation-map interactor From 9271da5070370a0ea4e2c2bada37ddf0bc53c408 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 22:12:44 -0600 Subject: [PATCH 23/42] More cleanups to require-all and unit tests --- core/vocabs/loader/loader.factor | 23 ++++++++++++----- extra/tools/test/test.factor | 44 ++++++++++++++++---------------- 2 files changed, 39 insertions(+), 28 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index e42dace945..352ef9fe02 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -148,10 +148,17 @@ SYMBOL: load-help? dup update-roots dup modified-sources swap modified-docs ; -: load-error. ( vocab error -- ) - "==== " write >r - dup vocab-name swap f >vocab-link write-object ":" print nl - r> print-error ; +: vocab-heading. ( vocab -- ) + nl + "==== " write + dup vocab-name swap f >vocab-link write-object ":" print + nl ; + +: load-error. ( triple -- ) + dup first vocab-heading. + dup second print-error + drop ; + ! third "Traceback" swap write-object ; TUPLE: require-all-error vocabs ; @@ -166,10 +173,14 @@ M: require-all-error summary dup length 1 = [ first require ] [ [ [ - [ [ require ] [ 2array , ] recover ] each + [ + [ require ] + [ error-continuation get 3array , ] + recover + ] each ] { } make dup empty? [ drop ] [ - dup [ nl load-error. ] assoc-each + dup [ load-error. nl ] each keys require-all-error ] if ] with-compiler-errors diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index d761df35d2..09d497aac7 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -11,7 +11,8 @@ SYMBOL: failures : ( error what -- triple ) error-continuation get 3array ; -: failure ( error what -- ) failures get push ; +: failure ( error what -- ) + failures get push ; SYMBOL: this-test @@ -45,16 +46,23 @@ M: expected-error summary : ignore-errors ( quot -- ) [ drop ] recover ; inline -: run-test ( path -- failures ) - [ "temporary" forget-vocab ] with-compilation-unit - [ - V{ } clone [ - failures [ - [ run-file ] [ swap failure ] recover - ] with-variable - ] keep - ] keep - [ forget-source ] with-compilation-unit ; +: (run-test) ( vocab -- ) + dup vocab-source-loaded? [ + vocab-tests-path dup [ + dup ?resource-path exists? [ + [ "temporary" forget-vocab ] with-compilation-unit + dup run-file + [ dup forget-source ] with-compilation-unit + ] when + ] when + ] when drop ; + +: run-test ( vocab -- failures ) + V{ } clone [ + failures [ + (run-test) + ] with-variable + ] keep ; : failure. ( triple -- ) dup second . @@ -70,8 +78,7 @@ M: expected-error summary ] [ "==== FAILING TESTS:" print [ - nl - "Failing tests in " write swap . + swap vocab-heading. [ nl failure. nl ] each ] assoc-each ] if @@ -79,19 +86,12 @@ M: expected-error summary drop "==== NOTHING TO TEST" print ] if ; -: run-vocab-tests ( vocabs -- failures ) - dup empty? [ f ] [ +: run-tests ( prefix -- failures ) + child-vocabs dup empty? [ f ] [ [ dup run-test ] { } map>assoc [ second empty? not ] subset ] if ; -: run-tests ( prefix -- failures ) - child-vocabs - [ vocab-source-loaded? ] subset - [ vocab-tests-path ] map - [ dup [ ?resource-path exists? ] when ] subset - run-vocab-tests ; - : test ( prefix -- ) run-tests failures. ; From 5ecf3f722587f95232485c21949b9983bdf549fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 22:58:41 -0600 Subject: [PATCH 24/42] Improve unit test documentation and update some tests --- core/bootstrap/image/image-tests.factor | 3 +- core/compiler/test/alien.factor | 6 +- core/compiler/test/redefine.factor | 8 +- core/inference/inference-docs.factor | 11 +- core/inference/inference-tests.factor | 115 +++++++++--------- .../transforms/transforms-tests.factor | 2 +- extra/combinators/lib/lib-tests.factor | 2 +- extra/io/launcher/launcher-tests.factor | 2 +- extra/io/server/server-tests.factor | 4 +- extra/tools/test/test-docs.factor | 77 ++++++++++-- extra/tools/test/test.factor | 17 ++- extra/ui/gadgets/books/books-tests.factor | 2 +- extra/ui/gadgets/buttons/buttons-tests.factor | 3 +- extra/ui/gadgets/editors/editors-tests.factor | 5 +- extra/ui/gadgets/gadgets-tests.factor | 2 +- .../gadgets/scrollers/scrollers-tests.factor | 2 +- extra/ui/tools/browser/browser-tests.factor | 3 +- .../tools/interactor/interactor-tests.factor | 2 +- extra/ui/tools/walker/walker-tests.factor | 2 +- .../ui/tools/workspace/workspace-tests.factor | 2 +- 20 files changed, 172 insertions(+), 98 deletions(-) mode change 100644 => 100755 extra/io/server/server-tests.factor diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor index ea533f0d6f..8c618a8f30 100755 --- a/core/bootstrap/image/image-tests.factor +++ b/core/bootstrap/image/image-tests.factor @@ -1,6 +1,5 @@ IN: temporary -USING: bootstrap.image bootstrap.image.private -tools.test.inference ; +USING: bootstrap.image bootstrap.image.private tools.test ; \ ' must-infer \ write-image must-infer diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index dbdbbfc9fa..4adb1c234b 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences inference words arrays parser quotations continuations inference.backend effects namespaces.private io io.streams.string memory system threads -tools.test.inference ; +tools.test ; FUNCTION: void ffi_test_0 ; [ ] [ ffi_test_0 ] unit-test @@ -80,7 +80,7 @@ FUNCTION: tiny ffi_test_17 int x ; : indirect-test-1 "int" { } "cdecl" alien-indirect ; -{ 1 1 } [ indirect-test-1 ] unit-test-effect +{ 1 1 } [ indirect-test-1 ] must-infer-as [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test @@ -89,7 +89,7 @@ FUNCTION: tiny ffi_test_17 int x ; : indirect-test-2 "int" { "int" "int" } "cdecl" alien-indirect data-gc ; -{ 3 1 } [ indirect-test-2 ] unit-test-effect +{ 3 1 } [ indirect-test-2 ] must-infer-as [ 5 ] [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index ab472668c3..9eaf2d1263 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -1,6 +1,6 @@ USING: compiler definitions generic assocs inference math namespaces parser tools.test words kernel sequences arrays io -effects tools.test.inference compiler.units inference.state ; +effects tools.test compiler.units inference.state ; IN: temporary DEFER: x-1 @@ -28,13 +28,13 @@ DEFER: c [ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test -{ 0 4 } [ b ] unit-test-effect +{ 0 4 } [ b ] must-infer-as [ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test [ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test -{ 0 6 } [ b ] unit-test-effect +{ 0 6 } [ b ] must-infer-as \ b word-xt "b-xt" set @@ -52,7 +52,7 @@ DEFER: c [ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test -{ 0 4 } [ c ] unit-test-effect +{ 0 4 } [ c ] must-infer-as [ f ] [ "c-xt" get \ c word-xt = ] unit-test diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 5f7e926b6a..68e5920a3d 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -73,6 +73,12 @@ $nl { $subsection infer-quot-value } "The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ; +ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph" +"The dataflow graph used by " { $link "compiler" } " can be obtained:" +{ $subsection dataflow } +"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form." +$nl ; + ARTICLE: "inference" "Stack effect inference" "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." $nl @@ -80,14 +86,15 @@ $nl { $subsection infer. } "Instead of printing the inferred information, it can be returned as objects on the stack:" { $subsection infer } -"The dataflow graph used by " { $link "compiler" } " can be obtained:" -{ $subsection dataflow } +"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "." +$nl "The following articles describe the implementation of the stack effect inference algorithm:" { $subsection "inference-simple" } { $subsection "inference-combinators" } { $subsection "inference-branches" } { $subsection "inference-recursive" } { $subsection "inference-limitations" } +{ $subsection "dataflow-graphs" } { $subsection "compiler-transforms" } ; ABOUT: "inference" diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index b43226166a..c5bc3b5fda 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -4,23 +4,22 @@ math.parser math.private namespaces namespaces.private parser sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector tuples classes.union classes.predicate -debugger threads.private io.streams.string combinators.private -tools.test.inference ; +debugger threads.private io.streams.string combinators.private ; IN: temporary -{ 0 2 } [ 2 "Hello" ] unit-test-effect -{ 1 2 } [ dup ] unit-test-effect +{ 0 2 } [ 2 "Hello" ] must-infer-as +{ 1 2 } [ dup ] must-infer-as -{ 1 2 } [ [ dup ] call ] unit-test-effect +{ 1 2 } [ [ dup ] call ] must-infer-as [ [ call ] infer ] must-fail -{ 2 4 } [ 2dup ] unit-test-effect +{ 2 4 } [ 2dup ] must-infer-as -{ 1 0 } [ [ ] [ ] if ] unit-test-effect +{ 1 0 } [ [ ] [ ] if ] must-infer-as [ [ if ] infer ] must-fail [ [ [ ] if ] infer ] must-fail [ [ [ 2 ] [ ] if ] infer ] must-fail -{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect +{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as { 4 3 } [ [ @@ -28,17 +27,17 @@ IN: temporary ] [ -rot ] if -] unit-test-effect +] must-infer-as -{ 1 1 } [ dup [ ] when ] unit-test-effect -{ 1 1 } [ dup [ dup fixnum* ] when ] unit-test-effect -{ 2 1 } [ [ dup fixnum* ] when ] unit-test-effect +{ 1 1 } [ dup [ ] when ] must-infer-as +{ 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as +{ 2 1 } [ [ dup fixnum* ] when ] must-infer-as -{ 1 0 } [ [ drop ] when* ] unit-test-effect -{ 1 1 } [ [ { { [ ] } } ] unless* ] unit-test-effect +{ 1 0 } [ [ drop ] when* ] must-infer-as +{ 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as { 0 1 } -[ [ 2 2 fixnum+ ] dup [ ] when call ] unit-test-effect +[ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as [ [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer @@ -50,7 +49,7 @@ IN: temporary : termination-test-2 [ termination-test-1 ] [ 3 ] if ; -{ 1 1 } [ termination-test-2 ] unit-test-effect +{ 1 1 } [ termination-test-2 ] must-infer-as : infinite-loop infinite-loop ; @@ -62,12 +61,12 @@ IN: temporary : simple-recursion-1 ( obj -- obj ) dup [ simple-recursion-1 ] [ ] if ; -{ 1 1 } [ simple-recursion-1 ] unit-test-effect +{ 1 1 } [ simple-recursion-1 ] must-infer-as : simple-recursion-2 ( obj -- obj ) dup [ ] [ simple-recursion-2 ] if ; -{ 1 1 } [ simple-recursion-2 ] unit-test-effect +{ 1 1 } [ simple-recursion-2 ] must-infer-as : bad-recursion-2 ( obj -- obj ) dup [ dup first swap second bad-recursion-2 ] [ ] if ; @@ -77,10 +76,10 @@ IN: temporary : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; -{ 1 1 } [ funny-recursion ] unit-test-effect +{ 1 1 } [ funny-recursion ] must-infer-as ! Simple combinators -{ 1 2 } [ [ first ] keep second ] unit-test-effect +{ 1 2 } [ [ first ] keep second ] must-infer-as ! Mutual recursion DEFER: foe @@ -103,8 +102,8 @@ DEFER: foe 2drop f ] if ; -{ 2 1 } [ fie ] unit-test-effect -{ 2 1 } [ foe ] unit-test-effect +{ 2 1 } [ fie ] must-infer-as +{ 2 1 } [ foe ] must-infer-as : nested-when ( -- ) t [ @@ -113,7 +112,7 @@ DEFER: foe ] when ] when ; -{ 0 0 } [ nested-when ] unit-test-effect +{ 0 0 } [ nested-when ] must-infer-as : nested-when* ( obj -- ) [ @@ -122,11 +121,11 @@ DEFER: foe ] when* ] when* ; -{ 1 0 } [ nested-when* ] unit-test-effect +{ 1 0 } [ nested-when* ] must-infer-as SYMBOL: sym-test -{ 0 1 } [ sym-test ] unit-test-effect +{ 0 1 } [ sym-test ] must-infer-as : terminator-branch dup [ @@ -135,7 +134,7 @@ SYMBOL: sym-test "foo" throw ] if ; -{ 1 1 } [ terminator-branch ] unit-test-effect +{ 1 1 } [ terminator-branch ] must-infer-as : recursive-terminator ( obj -- ) dup [ @@ -144,7 +143,7 @@ SYMBOL: sym-test "Hi" throw ] if ; -{ 1 0 } [ recursive-terminator ] unit-test-effect +{ 1 0 } [ recursive-terminator ] must-infer-as GENERIC: potential-hang ( obj -- obj ) M: fixnum potential-hang dup [ potential-hang ] when ; @@ -157,24 +156,24 @@ M: funny-cons iterate funny-cons-cdr iterate ; M: f iterate drop ; M: real iterate drop ; -{ 1 0 } [ iterate ] unit-test-effect +{ 1 0 } [ iterate ] must-infer-as ! Regression : cat ( obj -- * ) dup [ throw ] [ throw ] if ; : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ; -{ 3 0 } [ dog ] unit-test-effect +{ 3 0 } [ dog ] must-infer-as ! Regression DEFER: monkey : friend ( a b c -- ) dup [ friend ] [ monkey ] if ; : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ; -{ 3 0 } [ friend ] unit-test-effect +{ 3 0 } [ friend ] must-infer-as ! Regression -- same as above but we infer the second word first DEFER: blah2 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ; : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ; -{ 3 0 } [ blah2 ] unit-test-effect +{ 3 0 } [ blah2 ] must-infer-as ! Regression DEFER: blah4 @@ -182,7 +181,7 @@ DEFER: blah4 dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ; : blah4 ( a b c -- ) dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ; -{ 3 0 } [ blah4 ] unit-test-effect +{ 3 0 } [ blah4 ] must-infer-as ! Regression : bad-combinator ( obj quot -- ) @@ -199,7 +198,7 @@ DEFER: blah4 dup string? [ 2array throw ] unless over string? [ 2array throw ] unless ; -{ 2 2 } [ bad-input# ] unit-test-effect +{ 2 2 } [ bad-input# ] must-infer-as ! Regression @@ -218,7 +217,7 @@ DEFER: do-crap* ! Regression : too-deep ( a b -- c ) dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline -{ 2 1 } [ too-deep ] unit-test-effect +{ 2 1 } [ too-deep ] must-infer-as ! Error reporting is wrong MATH: xyz @@ -258,17 +257,17 @@ DEFER: C [ dup B C ] } dispatch ; -{ 1 0 } [ A ] unit-test-effect -{ 1 0 } [ B ] unit-test-effect -{ 1 0 } [ C ] unit-test-effect +{ 1 0 } [ A ] must-infer-as +{ 1 0 } [ B ] must-infer-as +{ 1 0 } [ C ] must-infer-as ! I found this bug by thinking hard about the previous one DEFER: Y : X ( a b -- c d ) dup [ swap Y ] [ ] if ; : Y ( a b -- c d ) X ; -{ 2 2 } [ X ] unit-test-effect -{ 2 2 } [ Y ] unit-test-effect +{ 2 2 } [ X ] must-infer-as +{ 2 2 } [ Y ] must-infer-as ! This one comes from UI code DEFER: #1 @@ -332,9 +331,9 @@ DEFER: bar [ [ get-slots ] infer ] [ inference-error? ] must-fail-with ! Test some curry stuff -{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect +{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as -{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect +{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail @@ -381,7 +380,7 @@ DEFER: bar \ assoc-like must-infer \ assoc-clone-like must-infer \ >alist must-infer -{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect +{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as ! Test some random library words \ 1quotation must-infer @@ -404,10 +403,10 @@ DEFER: bar \ define-predicate-class must-infer ! Test words with continuations -{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect -{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] unit-test-effect -{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect -{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect +{ 0 0 } [ [ drop ] callcc0 ] must-infer-as +{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as +{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as +{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as \ dispose must-infer @@ -450,13 +449,13 @@ DEFER: bar [ [ barxxx ] infer ] must-fail ! A typo -{ 1 0 } [ { [ ] } dispatch ] unit-test-effect +{ 1 0 } [ { [ ] } dispatch ] must-infer-as DEFER: inline-recursive-2 : inline-recursive-1 ( -- ) inline-recursive-2 ; : inline-recursive-2 ( -- ) inline-recursive-1 ; -{ 0 0 } [ inline-recursive-1 ] unit-test-effect +{ 0 0 } [ inline-recursive-1 ] must-infer-as ! Hooks SYMBOL: my-var @@ -465,22 +464,22 @@ HOOK: my-hook my-var ( -- x ) M: integer my-hook "an integer" ; M: string my-hook "a string" ; -{ 0 1 } [ my-hook ] unit-test-effect +{ 0 1 } [ my-hook ] must-infer-as DEFER: deferred-word : calls-deferred-word [ deferred-word ] [ 3 ] if ; -{ 1 1 } [ calls-deferred-word ] unit-test-effect +{ 1 1 } [ calls-deferred-word ] must-infer-as USE: inference.dataflow -{ 1 0 } [ [ iterate-next ] iterate-nodes ] unit-test-effect +{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as { 1 0 } [ [ [ iterate-next ] iterate-nodes ] with-node-iterator -] unit-test-effect +] must-infer-as : nilpotent ( quot -- ) t [ [ call ] keep nilpotent ] [ drop ] if ; inline @@ -490,11 +489,11 @@ USE: inference.dataflow { 0 1 } [ [ ] [ call ] keep [ [ call ] keep ] nilpotent ] -unit-test-effect +must-infer-as -{ 0 0 } [ [ ] semisimple ] unit-test-effect +{ 0 0 } [ [ ] semisimple ] must-infer-as -{ 1 0 } [ [ drop ] each-node ] unit-test-effect +{ 1 0 } [ [ drop ] each-node ] must-infer-as DEFER: an-inline-word @@ -510,9 +509,9 @@ DEFER: an-inline-word : an-inline-word ( obj quot -- ) >r normal-word r> call ; inline -{ 1 1 } [ [ 3 * ] an-inline-word ] unit-test-effect +{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as -{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] unit-test-effect +{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as TUPLE: custom-error ; @@ -536,4 +535,4 @@ TUPLE: custom-error ; ! This was a false trigger of the undecidable quotation ! recursion bug -{ 2 1 } [ find-last-sep ] unit-test-effect +{ 2 1 } [ find-last-sep ] must-infer-as diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index f58e557b10..0e5c3e231e 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: sequences inference.transforms tools.test math kernel -quotations tools.test.inference inference ; +quotations inference ; : compose-n-quot >quotation ; : compose-n compose-n-quot call ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 20f52b2ea3..24d70a86c6 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: combinators.lib kernel math math.ranges random sequences -tools.test tools.test.inference continuations arrays vectors ; +tools.test continuations arrays vectors ; IN: temporary [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test diff --git a/extra/io/launcher/launcher-tests.factor b/extra/io/launcher/launcher-tests.factor index b9f8f3e061..6705caa33c 100755 --- a/extra/io/launcher/launcher-tests.factor +++ b/extra/io/launcher/launcher-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test tools.test.inference io.launcher ; +USING: tools.test io.launcher ; \ must-infer diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor old mode 100644 new mode 100755 index 5c37a37380..776bc4b429 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test.inference io.server ; +USING: tools.test io.server ; -{ 1 0 } [ [ ] spawn-server ] unit-test-effect +{ 1 0 } [ [ ] spawn-server ] must-infer-as diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index 147e795861..c027073398 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -1,6 +1,36 @@ -USING: help.markup help.syntax kernel ; +USING: help.markup help.syntax kernel quotations io ; IN: tools.test +ARTICLE: "tools.test.write" "Writing unit tests" +"Assert that a quotation outputs a specific set of values:" +{ $subsection unit-test } +"Assert that a quotation throws an error:" +{ $subsection must-fail } +{ $subsection must-fail-with } +"Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):" +{ $subsection must-infer } +{ $subsection must-infer-as } ; + +ARTICLE: "tools.test.run" "Running unit tests" +"The following words run test harness files; any test failures are collected and printed at the end:" +{ $subsection test } +{ $subsection test-all } ; + +ARTICLE: "tools.test.failure" "Handling test failures" +"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Sometimes, you want to develop a tool which inspects the test failures and takes some kind of action instead; one example is " { $vocab-link "builder" } "." +$nl +"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:" +{ $list + { { $snippet "error" } " - the error thrown by the unit test" } + { { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" } + { { $snippet "continuation" } " - the traceback at the point of the error" } +} +"The following words run test harness files and output failures:" +{ $subsection run-tests } +{ $subsection run-all-tests } +"The following word prints failures:" +{ $subsection failures. } ; + ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." $nl @@ -8,13 +38,10 @@ $nl $nl "Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details." $nl -"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:" -{ $subsection unit-test } -{ $subsection must-fail } -{ $subsection must-fail-with } -"The following words run test harness files; any test failures are collected and printed at the end:" -{ $subsection test } -{ $subsection test-all } ; +"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run." +{ $subsection "tools.test.write" } +{ $subsection "tools.test.run" } +{ $subsection "tools.test.failure" } ; ABOUT: "tools.test" @@ -26,3 +53,37 @@ HELP: must-fail { $values { "quot" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, expecting it to throw an error. If the quotation throws an error, this word returns normally. If the quotation does not throw an error, this word " { $emphasis "does" } " raise an error." } { $notes "This word is used to test boundary conditions and fail-fast behavior." } ; + +HELP: must-fail-with +{ $values { "quot" "a quotation run with an empty stack" } { "pred" "a quotation with stack effect " { $snippet "( error -- ? )" } } } +{ $description "Runs a quotation with an empty stack, expecting it to throw an error which must satisfy " { $snippet "pred" } ". If the quotation does not throw an error, or if the error does not match the predicate, the unit test fails." } +{ $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ; + +HELP: must-infer +{ $values { "word/quot" "a quotation or a word" } } +{ $description "Ensures that the quotation or word has a static stack effect without running it." } +{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ; + +HELP: must-infer-as +{ $values { "effect" "a pair with shape " { $snippet "{ inputs outputs }" } } { "quot" quotation } } +{ $description "Ensures that the quotation has the indicated stack effect without running it." } +{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ; + +HELP: test +{ $values { "prefix" "a vocabulary name" } } +{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ; + +HELP: run-tests +{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } +{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; + +HELP: test-all +{ $description "Runs unit tests for all loaded vocabularies." } ; + +HELP: run-all-tests +{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } +{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; + +HELP: failure. +{ $values { "failures" "an association list of unit test failures" } } +{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to the " { $link stdio } " stream." } ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 09d497aac7..0b1a495e90 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -3,7 +3,8 @@ USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.files vocabs tools.time -vocabs.loader source-files compiler.units inspector ; +vocabs.loader source-files compiler.units inspector +inference effects ; IN: tools.test SYMBOL: failures @@ -29,13 +30,23 @@ SYMBOL: this-test { } swap with-datastack swap >array assert= ] 2curry (unit-test) ; +: short-effect ( effect -- pair ) + dup effect-in length swap effect-out length 2array ; + +: must-infer-as ( effect quot -- ) + >r 1quotation r> [ infer short-effect ] curry unit-test ; + +: must-infer ( word/quot -- ) + dup word? [ 1quotation ] when + [ infer drop ] curry [ ] swap unit-test ; + TUPLE: expected-error ; M: expected-error summary drop "The unit test expected the quotation to throw an error" ; -: must-fail-with ( quot test -- ) +: must-fail-with ( quot pred -- ) >r [ expected-error construct-empty throw ] compose r> [ recover ] 2curry [ t ] swap unit-test ; @@ -60,7 +71,7 @@ M: expected-error summary : run-test ( vocab -- failures ) V{ } clone [ failures [ - (run-test) + [ (run-test) ] [ swap failure ] recover ] with-variable ] keep ; diff --git a/extra/ui/gadgets/books/books-tests.factor b/extra/ui/gadgets/books/books-tests.factor index 35016e1669..9e1b0aa985 100755 --- a/extra/ui/gadgets/books/books-tests.factor +++ b/extra/ui/gadgets/books/books-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test.inference ui.gadgets.books ; +USING: tools.test ui.gadgets.books ; \ must-infer diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index 77dfd30d96..224ef9e1ce 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -1,7 +1,6 @@ IN: temporary USING: ui.commands ui.gadgets.buttons ui.gadgets.labels -ui.gadgets tools.test namespaces sequences kernel models -tools.test.inference ; +ui.gadgets tools.test namespaces sequences kernel models ; TUPLE: foo-gadget ; diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor index bc302c1a09..f3a6b9fd5d 100755 --- a/extra/ui/gadgets/editors/editors-tests.factor +++ b/extra/ui/gadgets/editors/editors-tests.factor @@ -1,7 +1,6 @@ USING: ui.gadgets.editors tools.test kernel io io.streams.plain -definitions namespaces ui.gadgets -ui.gadgets.grids prettyprint documents ui.gestures -tools.test.inference tools.test.ui models ; +definitions namespaces ui.gadgets ui.gadgets.grids prettyprint +documents ui.gestures tools.test.ui models ; [ "foo bar" ] [ "editor" set diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index 81b30559df..1e27744f33 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test -namespaces models kernel tools.test.inference dlists math +namespaces models kernel dlists math math.parser ui sequences hashtables assocs io arrays prettyprint io.streams.string ; diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index 30ba4a18f3..dd667fdfec 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -3,7 +3,7 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test kernel models ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames ui.gadgets.sliders math math.vectors arrays sequences -tools.test.inference tools.test.ui ; +tools.test.ui ; [ ] [ "g" set diff --git a/extra/ui/tools/browser/browser-tests.factor b/extra/ui/tools/browser/browser-tests.factor index 3102ad1bd9..7262c72756 100755 --- a/extra/ui/tools/browser/browser-tests.factor +++ b/extra/ui/tools/browser/browser-tests.factor @@ -1,6 +1,5 @@ IN: temporary -USING: tools.test tools.test.ui ui.tools.browser -tools.test.inference ; +USING: tools.test tools.test.ui ui.tools.browser ; \ must-infer [ ] [ [ ] with-grafted-gadget ] unit-test diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index bf9de10a1e..0422c4170a 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: ui.tools.interactor tools.test.inference ; +USING: ui.tools.interactor tools.test ; \ must-infer diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor index a23b629d1e..acf0a39bfb 100755 --- a/extra/ui/tools/walker/walker-tests.factor +++ b/extra/ui/tools/walker/walker-tests.factor @@ -2,7 +2,7 @@ USING: arrays continuations ui.tools.listener ui.tools.walker ui.tools.workspace inspector kernel namespaces sequences threads listener tools.test ui ui.gadgets ui.gadgets.worlds ui.gadgets.packs vectors ui.tools tools.interpreter -tools.interpreter.debug tools.test.inference tools.test.ui ; +tools.interpreter.debug tools.test.ui ; IN: temporary \ must-infer diff --git a/extra/ui/tools/workspace/workspace-tests.factor b/extra/ui/tools/workspace/workspace-tests.factor index 41f0151746..5e3695fed3 100755 --- a/extra/ui/tools/workspace/workspace-tests.factor +++ b/extra/ui/tools/workspace/workspace-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test tools.test.inference ui.tools ; +USING: tools.test ui.tools ; \ must-infer From 78abc143d626838d551592dd61bf1de31e4fe458 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:01:14 -0600 Subject: [PATCH 25/42] Load fix --- core/math/parser/parser-docs.factor | 11 +- .../furnace-pastebin/annotate-paste.furnace | 28 ----- .../furnace-pastebin/annotation.furnace | 11 -- unmaintained/furnace-pastebin/load.factor | 4 - .../furnace-pastebin/new-paste.furnace | 27 ----- .../furnace-pastebin/paste-list.furnace | 7 -- .../furnace-pastebin/paste-summary.furnace | 9 -- unmaintained/furnace-pastebin/pastebin.factor | 110 ------------------ .../furnace-pastebin/show-paste.furnace | 15 --- 9 files changed, 1 insertion(+), 221 deletions(-) delete mode 100644 unmaintained/furnace-pastebin/annotate-paste.furnace delete mode 100644 unmaintained/furnace-pastebin/annotation.furnace delete mode 100644 unmaintained/furnace-pastebin/load.factor delete mode 100644 unmaintained/furnace-pastebin/new-paste.furnace delete mode 100644 unmaintained/furnace-pastebin/paste-list.furnace delete mode 100644 unmaintained/furnace-pastebin/paste-summary.furnace delete mode 100644 unmaintained/furnace-pastebin/pastebin.factor delete mode 100644 unmaintained/furnace-pastebin/show-paste.furnace diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index b0d52ef2ef..1d2a24057c 100644 --- a/core/math/parser/parser-docs.factor +++ b/core/math/parser/parser-docs.factor @@ -25,14 +25,10 @@ $nl ABOUT: "number-strings" HELP: digits>integer -{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "n" integer } } +{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } } { $description "Converts a sequence of digits (with most significant digit first) into an integer." } { $notes "This is one of the factors of " { $link string>number } "." } ; -HELP: valid-digits? -{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "?" "a boolean" } } -{ $description "Tests if this sequence of integers represents a valid integer in the given radix." } ; - HELP: >digit { $values { "n" "an integer between 0 and 35" } { "ch" "a character" } } { $description "Outputs a character representation of a digit." } @@ -43,11 +39,6 @@ HELP: digit> { $description "Converts a character representation of a digit to an integer." } { $notes "This is one of the factors of " { $link string>number } "." } ; -HELP: string>integer -{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "an integer or " { $link f } } } -{ $description "Creates an integer from a string representation." } -{ $notes "The " { $link base> } " word is more general." } ; - HELP: base> { $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "a real number or " { $link f } } } { $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10." diff --git a/unmaintained/furnace-pastebin/annotate-paste.furnace b/unmaintained/furnace-pastebin/annotate-paste.furnace deleted file mode 100644 index 24f0d4ea94..0000000000 --- a/unmaintained/furnace-pastebin/annotate-paste.furnace +++ /dev/null @@ -1,28 +0,0 @@ -<% USING: namespaces math io ; %> - -

Annotate

- -
- - - -string write %>" /> - - - - - - - - - - - - - - - -
Summary:
Your name:
Contents:
- - -
diff --git a/unmaintained/furnace-pastebin/annotation.furnace b/unmaintained/furnace-pastebin/annotation.furnace deleted file mode 100644 index ed1bdac845..0000000000 --- a/unmaintained/furnace-pastebin/annotation.furnace +++ /dev/null @@ -1,11 +0,0 @@ -<% USING: namespaces io ; %> - -

Annotation: <% "summary" get write %>

- - - - - -
Annotation by:<% "author" get write %>
Channel:<% "channel" get write %>
Created:<% "date" get write %>
- -
<% "contents" get write %>
diff --git a/unmaintained/furnace-pastebin/load.factor b/unmaintained/furnace-pastebin/load.factor deleted file mode 100644 index 4f3bdc8db9..0000000000 --- a/unmaintained/furnace-pastebin/load.factor +++ /dev/null @@ -1,4 +0,0 @@ -REQUIRES: libs/concurrency libs/furnace libs/irc libs/store ; - -PROVIDE: apps/furnace-pastebin -{ +files+ { "pastebin.factor" } } ; diff --git a/unmaintained/furnace-pastebin/new-paste.furnace b/unmaintained/furnace-pastebin/new-paste.furnace deleted file mode 100644 index 36f0397b67..0000000000 --- a/unmaintained/furnace-pastebin/new-paste.furnace +++ /dev/null @@ -1,27 +0,0 @@ -
- - - - - - - - - - - - - - - - - - - - - - -
Summary:
Your name:
Channel:
Contents:
- - -
diff --git a/unmaintained/furnace-pastebin/paste-list.furnace b/unmaintained/furnace-pastebin/paste-list.furnace deleted file mode 100644 index 7a25ae2f50..0000000000 --- a/unmaintained/furnace-pastebin/paste-list.furnace +++ /dev/null @@ -1,7 +0,0 @@ -<% USING: namespaces furnace sequences ; %> - - -<% "new-paste-quot" get "New paste" render-link %> - -<% "pastes" get [ "paste-summary" render-template ] each %>
 Summary:Paste by:LinkDate
- diff --git a/unmaintained/furnace-pastebin/paste-summary.furnace b/unmaintained/furnace-pastebin/paste-summary.furnace deleted file mode 100644 index ad54c8d397..0000000000 --- a/unmaintained/furnace-pastebin/paste-summary.furnace +++ /dev/null @@ -1,9 +0,0 @@ -<% USING: namespaces io kernel math furnace ; %> - - -<% "n" get number>string write %> -<% "summary" get write %> -<% "author" get write %> -<% "n" get number>string "show-paste-quot" get curry "Show" render-link %> -<% "date" get print %> - diff --git a/unmaintained/furnace-pastebin/pastebin.factor b/unmaintained/furnace-pastebin/pastebin.factor deleted file mode 100644 index b11129312f..0000000000 --- a/unmaintained/furnace-pastebin/pastebin.factor +++ /dev/null @@ -1,110 +0,0 @@ -IN: furnace:pastebin -USING: calendar concurrency irc kernel namespaces sequences -furnace hashtables math store ; - -TUPLE: paste n summary author channel contents date annotations ; - -TUPLE: annotation summary author contents ; - -C: paste ( summary author channel contents -- paste ) - V{ } clone over set-paste-annotations - [ set-paste-contents ] keep - [ set-paste-channel ] keep - [ set-paste-author ] keep - [ set-paste-summary ] keep ; - -TUPLE: pastebin pastes ; - -C: pastebin ( -- pastebin ) - V{ } clone over set-pastebin-pastes ; - -SYMBOL: store -"pastebin.store" load-store store set-global - pastebin store get store-variable - -: add-paste ( paste pastebin -- ) - now timestamp>http-string pick set-paste-date - dup pastebin-pastes length pick set-paste-n - pastebin-pastes push ; - -: get-paste ( n -- paste ) - pastebin get pastebin-pastes nth ; - -: show-paste ( n -- ) - get-paste "show-paste" "Paste" render-page ; - -\ show-paste { { "n" v-number } } define-action - -: new-paste ( -- ) - f "new-paste" "New paste" render-page ; - -\ new-paste { } define-action - -: make-remote-process - "trifocus.net" 4030 "public-irc" ; - -: alert-new-paste ( paste -- ) - >r make-remote-process r> - f over paste-channel rot [ - dup paste-author % - " pasted " % - CHAR: " , - dup paste-summary % - CHAR: " , - " at " % - "http://wee-url.com/responder/pastebin/show-paste?n=" % - paste-n # - ] "" make swap send ; - -: alert-annotation ( annotation paste -- ) - make-remote-process -rot - f over paste-channel 2swap [ - over annotation-author % - " annotated paste " % - " with \"" % - over annotation-summary % - "\" at " % - "http://wee-url.com/responder/pastebin/show-paste?n=" % - dup paste-n # - 2drop - ] "" make swap send ; - - -: submit-paste ( summary author channel contents -- ) - dup pastebin get-global add-paste - alert-new-paste store get save-store ; - -\ submit-paste { - { "summary" v-required } - { "author" v-required } - { "channel" "#concatenative" v-default } - { "contents" v-required } -} define-action - -: paste-list ( -- ) - [ - [ show-paste ] "show-paste-quot" set - [ new-paste ] "new-paste-quot" set - - pastebin get "paste-list" "Pastebin" render-page - ] with-scope ; - -\ paste-list { } define-action - -\ submit-paste [ paste-list ] define-redirect - -: annotate-paste ( paste# summary author contents -- ) - swap get-paste - [ paste-annotations push ] 2keep - alert-annotation store get save-store ; - -\ annotate-paste { - { "n" v-required v-number } - { "summary" v-required } - { "author" v-required } - { "contents" v-required } -} define-action - -\ annotate-paste [ "n" show-paste ] define-redirect - -"pastebin" "paste-list" "apps/furnace-pastebin" web-app diff --git a/unmaintained/furnace-pastebin/show-paste.furnace b/unmaintained/furnace-pastebin/show-paste.furnace deleted file mode 100644 index b3b4e99b6e..0000000000 --- a/unmaintained/furnace-pastebin/show-paste.furnace +++ /dev/null @@ -1,15 +0,0 @@ -<% USING: namespaces io furnace sequences ; %> - -

Paste: <% "summary" get write %>

- - - - - -
Paste by:<% "author" get write %>
Channel:<% "channel" get write %>
Created:<% "date" get write %>
- -
<% "contents" get write %>
- -<% "annotations" get [ "annotation" render-template ] each %> - -<% model get "annotate-paste" render-template %> From 831b712f848c90d97e5431e25ff47f122c27843e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:02:26 -0600 Subject: [PATCH 26/42] Move logging code to io.logging --- extra/io/logging/authors.txt | 1 + extra/io/logging/logging-docs.factor | 26 +++++++++++++++ extra/io/logging/logging.factor | 47 ++++++++++++++++++++++++++++ extra/io/logging/summary.txt | 1 + extra/io/server/server-docs.factor | 23 -------------- extra/io/server/server.factor | 41 ++---------------------- 6 files changed, 77 insertions(+), 62 deletions(-) create mode 100644 extra/io/logging/authors.txt create mode 100644 extra/io/logging/logging-docs.factor create mode 100644 extra/io/logging/logging.factor create mode 100644 extra/io/logging/summary.txt diff --git a/extra/io/logging/authors.txt b/extra/io/logging/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/logging/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/logging/logging-docs.factor b/extra/io/logging/logging-docs.factor new file mode 100644 index 0000000000..6cd03ce212 --- /dev/null +++ b/extra/io/logging/logging-docs.factor @@ -0,0 +1,26 @@ +IN: io.logging +USING: help.markup help.syntax io ; + +HELP: log-stream +{ $var-description "Holds an output stream for logging messages." } +{ $see-also log-error log-client with-logging } ; + +HELP: log-message +{ $values { "str" "a string" } } +{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." } +{ $see-also log-error log-client } ; + +HELP: log-error +{ $values { "str" "a string" } } +{ $description "Logs an error message." } +{ $see-also log-message log-client } ; + +HELP: log-client +{ $values { "client" "a client socket stream" } } +{ $description "Logs an incoming client connection." } +{ $see-also log-message log-error } ; + +HELP: with-logging +{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } } +{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ; + diff --git a/extra/io/logging/logging.factor b/extra/io/logging/logging.factor new file mode 100644 index 0000000000..bd9dc0862e --- /dev/null +++ b/extra/io/logging/logging.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel io calendar sequences io.files +io.sockets continuations prettyprint ; +IN: io.logging + +SYMBOL: log-stream + +: to-log-stream ( quot -- ) + log-stream get swap with-stream* ; inline + +: log-message ( str -- ) + [ + "[" write now timestamp>string write "] " write + print flush + ] to-log-stream ; + +: log-error ( str -- ) "Error: " swap append log-message ; + +: log-client ( client -- ) + "Accepted connection from " + swap client-stream-addr unparse append log-message ; + +: log-file ( service -- path ) + ".log" append resource-path ; + +: with-log-stream ( stream quot -- ) + log-stream get [ nip call ] [ + log-stream swap with-variable + ] if ; inline + +: with-log-file ( file quot -- ) + >r r> + [ with-log-stream ] curry + with-disposal ; inline + +: with-log-stdio ( quot -- ) + stdio get swap with-log-stream ; inline + +: with-logging ( service quot -- ) + over [ + >r log-file + "Writing log messages to " write dup print flush r> + with-log-file + ] [ + nip with-log-stdio + ] if ; inline diff --git a/extra/io/logging/summary.txt b/extra/io/logging/summary.txt new file mode 100644 index 0000000000..0edce8f0cf --- /dev/null +++ b/extra/io/logging/summary.txt @@ -0,0 +1 @@ +Basic logging framework for server applications diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor index ea8320f18d..4e4342266a 100644 --- a/extra/io/server/server-docs.factor +++ b/extra/io/server/server-docs.factor @@ -1,29 +1,6 @@ USING: help help.syntax help.markup io ; IN: io.server -HELP: log-stream -{ $var-description "Holds an output stream for logging messages." } -{ $see-also log-error log-client with-logging } ; - -HELP: log-message -{ $values { "str" "a string" } } -{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." } -{ $see-also log-error log-client } ; - -HELP: log-error -{ $values { "str" "a string" } } -{ $description "Logs an error message." } -{ $see-also log-message log-client } ; - -HELP: log-client -{ $values { "client" "a client socket stream" } } -{ $description "Logs an incoming client connection." } -{ $see-also log-message log-error } ; - -HELP: with-logging -{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } } -{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ; - HELP: with-client { $values { "quot" "a quotation" } { "client" "a client socket stream" } } { $description "Logs a client connection and spawns a new thread that calls the quotation, with the " { $link stdio } " stream set to the client stream. If the quotation throws an error, the client connection is closed, and the error is printed to the " { $link stdio } " stream at the time the thread was spawned." } ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 3c3d2c20f5..182712c984 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,49 +1,12 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.sockets io.files continuations kernel math -math.parser namespaces parser sequences strings +USING: io io.sockets io.files io.logging continuations kernel +math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar qualified ; QUALIFIED: concurrency IN: io.server -SYMBOL: log-stream - -: with-log-stream ( quot -- ) - log-stream get swap with-stream* ; inline - -: log-message ( str -- ) - [ - "[" write now timestamp>string write "] " write - print flush - ] with-log-stream ; - -: log-error ( str -- ) "Error: " swap append log-message ; - -: log-client ( client -- ) - "Accepted connection from " - swap client-stream-addr unparse append log-message ; - -: log-file ( service -- path ) - ".log" append resource-path ; - -: with-log-file ( file quot -- ) - >r r> - [ log-stream swap with-variable ] curry - with-disposal ; inline - -: with-log-stdio ( quot -- ) - stdio get log-stream rot with-variable ; inline - -: with-logging ( service quot -- ) - over [ - >r log-file - "Writing log messages to " write dup print flush r> - with-log-file - ] [ - nip with-log-stdio - ] if ; inline - : with-client ( quot client -- ) dup log-client [ swap with-stream ] 2curry concurrency:spawn drop ; inline From 6373e350baf86d3814fdd05c3614522db84cd4b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:02:38 -0600 Subject: [PATCH 27/42] Removed test-changes word --- extra/ui/tools/tools.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 8e2eeaa0ba..71a7080c86 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -80,14 +80,10 @@ H{ { +nullary+ t } } define-command \ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command -\ test-changes -H{ { +nullary+ t } { +listener+ t } } define-command - workspace "workflow" f { { T{ key-down f { C+ } "n" } workspace-window } { T{ key-down f f "ESC" } hide-popup } { T{ key-down f f "F2" } refresh-all } - { T{ key-down f { A+ } "F2" } test-changes } } define-command-map [ From a06c536123a2b8a1c7785caa591a9bdf1e742cbc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:03:27 -0600 Subject: [PATCH 28/42] Cleaned up SMTP implementation and added some features --- extra/smtp/authors.txt | 2 + extra/smtp/server/server.factor | 72 ++++++++++ extra/smtp/smtp-tests.factor | 130 ++++++++++++++---- extra/smtp/smtp.factor | 237 ++++++++++++++++++-------------- 4 files changed, 310 insertions(+), 131 deletions(-) create mode 100644 extra/smtp/server/server.factor diff --git a/extra/smtp/authors.txt b/extra/smtp/authors.txt index 7c29e7c401..159b1e91e9 100644 --- a/extra/smtp/authors.txt +++ b/extra/smtp/authors.txt @@ -1 +1,3 @@ Elie Chaftari +Dirk Vleugels +Slava Pestov diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor new file mode 100644 index 0000000000..2cfc1e65e4 --- /dev/null +++ b/extra/smtp/server/server.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2007 Elie CHAFTARI +! See http://factorcode.org/license.txt for BSD license. + +! Mock SMTP server for testing purposes. + +! Usage: 4321 smtp-server +! $ telnet 127.0.0.1 4321 +! Trying 127.0.0.1... +! Connected to localhost. +! Escape character is '^]'. +! 220 hello +! EHLO +! 220 and..? +! MAIL FROM: +! 220 OK +! RCPT TO: +! 220 OK +! Hi +! 500 ERROR +! DATA +! 354 Enter message, ending with "." on a line by itself +! Hello I am still waiting for your call +! Thanks +! . +! 220 OK +! QUIT +! bye +! Connection closed by foreign host. + +USING: combinators kernel prettyprint io io.server sequences +namespaces io.sockets continuations ; + +SYMBOL: data-mode + +: process ( -- ) + readln { + { [ [ dup "HELO" head? ] keep "EHLO" head? or ] [ + "220 and..?\r\n" write flush t + ] } + { [ dup "QUIT" = ] [ + "bye\r\n" write flush f + ] } + { [ dup "MAIL FROM:" head? ] [ + "220 OK\r\n" write flush t + ] } + { [ dup "RCPT TO:" head? ] [ + "220 OK\r\n" write flush t + ] } + { [ dup "DATA" = ] [ + data-mode on + "354 Enter message, ending with \".\" on a line by itself\r\n" + write flush t + ] } + { [ dup "." = data-mode get and ] [ + data-mode off + "220 OK\r\n" write flush t + ] } + { [ data-mode get ] [ t ] } + { [ t ] [ + "500 ERROR\r\n" write flush t + ] } + } cond nip [ process ] when ; + +: smtp-server ( port -- ) + "Starting SMTP server on port " write dup . flush + "127.0.0.1" swap [ + accept [ + 60000 stdio get set-timeout + "220 hello\r\n" write flush + process + ] with-stream + ] with-disposal ; diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 8ab1fd0899..9a357fdc7d 100644 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,41 +1,111 @@ -! Tested with Apache JAMES version 2.3.1 on localhost -! cram-md5 authentication tested against Exim 4 -! Replace "localhost" with your smtp server -! e.g. "your.smtp.server" initialize +USING: smtp tools.test io.streams.string io.logging threads +smtp.server kernel sequences namespaces ; +IN: temporary -USING: smtp tools.test ; +{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as -"localhost" initialize ! replace localhost with your smtp server +[ "hello\nworld" validate-address ] must-fail -! 8889 set-port ! default port = 25, change for testing purposes +[ "slava@factorcode.org" ] +[ "slava@factorcode.org" validate-address ] unit-test -! 30000 set-read-timeout ! default = 60000 -! f set-esmtp ! when esmtp (extended smtp) is not supported +[ { "hello" "." "world" } validate-message ] must-fail -start +[ "hello\r\nworld\r\n.\r\n" ] [ + { "hello" "world" } [ send-body ] string-out +] unit-test -! "md5 password here" "login" cram-md5-auth +[ + [ + "500 syntax error" check-response + ] with-log-stdio +] must-fail -"root@localhost" mailfrom ! your@mail.address +[ ] [ + [ + "220 success" check-response + ] with-log-stdio +] unit-test -"root@localhost" rcptto ! someone@example.com +[ "220 success" ] [ + "220 success" [ receive-response ] string-in +] unit-test -! { "From: Your Name " -! "To: Destination Address " -! "Subject: test message" -! "Date: Thu, 17 May 2007 18:46:45 +0200" -! "Message-Id: " -! " " -! "This is a test message." -! } send-message +[ "220 the end" ] [ + [ + "220-a multiline response\r\n250-another line\r\n220 the end" + [ receive-response ] string-in + ] with-log-stdio +] unit-test -{ "From: Your Name " - "To: Destination Address " - "Subject: test message" - "Date: Thu, 17 May 2007 18:46:45 +0200" - "Message-Id: " - " " - "This is a test message." -} send-message +[ ] [ + [ + "220-a multiline response\r\n250-another line\r\n220 the end" + [ get-ok ] string-in + ] with-log-stdio +] unit-test -quit \ No newline at end of file +[ + "Subject:\r\nsecurity hole" validate-header +] must-fail + +[ + V{ + { "To" "Slava , Ed " } + { "From" "Doug " } + { "Subject" "Factor rules" } + } + { "slava@factorcode.org" "dharmatech@factorcode.org" } + "erg@factorcode.org" +] [ + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + simple-headers >r >r 2 head* r> r> +] unit-test + +[ + { + "To: Slava , Ed " + "From: Doug " + "Subject: Factor rules" + f + f + " " + "Hi guys" + "Bye guys" + } + { "slava@factorcode.org" "dharmatech@factorcode.org" } + "erg@factorcode.org" +] [ + "Hi guys\nBye guys" + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + prepare-simple-message + >r >r f 3 pick set-nth f 4 pick set-nth r> r> +] unit-test + +[ ] [ [ 4321 smtp-server ] in-thread ] unit-test + +[ ] [ + [ + 4321 smtp-port set + + "Hi guys\nBye guys" + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + + send-simple-message + ] with-scope +] unit-test \ No newline at end of file diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 9116d094de..77bfb6cd82 100644 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -1,138 +1,173 @@ -! Copyright (C) 2007 Elie CHAFTARI +! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -! -! cram-md5 auth code contributed by Dirk Vleugels - -USING: alien alien.c-types combinators crypto.common crypto.hmac base64 -kernel io io.sockets namespaces sequences splitting ; +USING: namespaces io kernel io.logging io.sockets sequences +combinators sequences.lib splitting assocs strings math.parser +random system calendar ; IN: smtp -! ========================================================= -! smtp.factor implementation -! ========================================================= +SYMBOL: smtp-domain +SYMBOL: smtp-host "localhost" smtp-host set-global +SYMBOL: smtp-port 25 smtp-port set-global +SYMBOL: read-timeout 60000 read-timeout set-global +SYMBOL: esmtp t esmtp set-global -! Connection default values -: default-port 25 ; inline -: read-timeout 60000 ; inline -: esmtp t ; inline ! t = ehlo -: domain "localhost.localdomain" ; inline +: log-smtp-connection ( host port -- ) + [ + "Establishing SMTP connection to " % swap % ":" % # + ] "" make log-message ; -SYMBOL: sess -SYMBOL: conn -SYMBOL: challenge +: with-smtp-connection ( quot -- ) + [ + smtp-host get smtp-port get + 2dup log-smtp-connection + [ + smtp-domain [ host-name or ] change + read-timeout get stdio get set-timeout + call + ] with-stream + ] with-log-stdio ; inline -TUPLE: session address port timeout domain esmtp ; +: crlf "\r\n" write ; -: ( address -- session ) - default-port read-timeout domain esmtp - session construct-boa ; +: helo ( -- ) + esmtp get "EHLO " "HELO " ? write host-name write crlf ; -! ========================================================= -! Initialization routines -! ========================================================= +: validate-address ( string -- string' ) + #! Make sure we send funky stuff to the server by accident. + dup [ "\r\n>" member? ] contains? + [ "Bad e-mail address: " swap append throw ] when ; -: initialize ( address -- ) - sess set ; +: mail-from ( fromaddr -- ) + "MAIL FROM:<" write validate-address write ">" write crlf ; -: set-port ( port -- ) - sess get set-session-port ; +: rcpt-to ( to -- ) + "RCPT TO:<" write validate-address write ">" write crlf ; -: set-read-timeout ( timeout -- ) - sess get set-session-timeout ; +: data ( -- ) + "DATA" write crlf ; -: set-esmtp ( esmtp -- ) - sess get set-session-esmtp ; +: validate-message ( msg -- msg' ) + "." over member? [ "Message cannot contain . on a line by itself" throw ] when ; -: set-domain ( -- ) - host-name sess get set-session-domain ; +: send-body ( body -- ) + validate-message + [ write crlf ] each + "." write crlf ; -: do-start ( -- ) - sess get [ session-address ] keep session-port - dup conn set [ sess get session-timeout swap set-timeout ] - keep stream-readln print ; +: quit ( -- ) + "QUIT" write crlf ; -! ========================================================= -! Command routines -! ========================================================= +: log-response ( string -- ) "SMTP: " swap append log-message ; : check-response ( response -- ) { - { [ dup "220" head? ] [ print ] } - { [ dup "235" swap subseq? ] [ print ] } - { [ dup "250" head? ] [ print ] } - { [ dup "221" head? ] [ print ] } - { [ dup "bye" head? ] [ print ] } + { [ dup "220" head? ] [ log-response ] } + { [ dup "235" swap subseq? ] [ log-response ] } + { [ dup "250" head? ] [ log-response ] } + { [ dup "221" head? ] [ log-response ] } + { [ dup "bye" head? ] [ log-response ] } { [ dup "4" head? ] [ "server busy" throw ] } - { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } - { [ dup "354" head? ] [ print ] } - { [ dup "50" head? ] [ print "syntax error" throw ] } - { [ dup "53" head? ] [ print "invalid authentication data" throw ] } - { [ dup "55" head? ] [ print "fatal error" throw ] } - { [ t ] [ "unknow error" throw ] } + { [ dup "354" head? ] [ log-response ] } + { [ dup "50" head? ] [ log-response "syntax error" throw ] } + { [ dup "53" head? ] [ log-response "invalid authentication data" throw ] } + { [ dup "55" head? ] [ log-response "fatal error" throw ] } + { [ t ] [ "unknown error" throw ] } } cond ; -SYMBOL: multiline - : multiline? ( response -- boolean ) - CHAR: - swap index 3 = ; + ?fourth CHAR: - = ; -: process-multiline ( -- response ) - conn get stream-readln dup - multiline get " " append head? [ - print +: process-multiline ( multiline -- response ) + >r readln r> 2dup " " append head? [ + drop dup log-response ] [ - check-response process-multiline + swap check-response process-multiline ] if ; -: recv-response ( -- response ) - conn get stream-readln - dup multiline? [ - dup 3 head multiline set process-multiline - ] [ ] if ; +: receive-response ( -- response ) + readln + dup multiline? [ 3 head process-multiline ] when ; -: get-ok ( command -- ) - >r conn get r> over stream-write stream-flush - recv-response check-response ; +: get-ok ( -- ) flush receive-response check-response ; -: helo ( -- ) - "HELO " sess get session-domain append "\r\n" append get-ok ; +: send-raw-message ( body to from -- ) + [ + helo get-ok + mail-from get-ok + [ rcpt-to get-ok ] each + data get-ok + send-body get-ok + quit get-ok + ] with-smtp-connection ; -: ehlo ( -- ) - "EHLO " sess get session-domain append "\r\n" append get-ok ; +: validate-header ( string -- string' ) + dup [ "\r\n" member? ] contains? + [ "Invalid header string: " swap append throw ] when ; -: mailfrom ( fromaddr -- ) - "MAIL FROM:<" swap append ">\r\n" append get-ok ; +: prepare-header ( key value -- ) + swap + validate-header % + ": " % + validate-header % ; -: rcptto ( to -- ) - "RCPT TO:<" swap append ">\r\n" append get-ok ; +: prepare-headers ( assoc -- ) + [ [ prepare-header ] "" make , ] assoc-each ; -: (cram-md5-auth) ( -- response ) - swap challenge get - string>md5-hmac hex-string - " " swap append append - >base64 ; +: extract-email ( recepient -- email ) + #! This could be much smarter. + " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ; -: cram-md5-auth ( key login -- ) - "AUTH CRAM-MD5\r\n" get-ok - (cram-md5-auth) "\r\n" append get-ok ; - -: data ( -- ) - "DATA\r\n" get-ok ; +: message-id ( -- string ) + [ + "<" % + 2 big-random # + "-" % + millis # + "@" % + smtp-domain get % + ">" % + ] "" make ; -: start ( -- ) - set-domain ! replaces localhost.localdomain with hostname - do-start - sess get session-esmtp [ - ehlo - ] [ - helo - ] if ; +: simple-headers ( subject to from -- headers to from ) + [ + >r dup ", " join "To" set [ extract-email ] map r> + dup "From" set extract-email + rot "Subject" set + now timestamp>rfc822-string "Date" set + message-id "Message-Id" set + ] { } make-assoc -rot ; -: send-message ( msg -- ) - data - "\r\n" join conn get swap "\r\n" append over stream-write - stream-flush ".\r\n" get-ok ; +: prepare-message ( body headers -- body' ) + [ + prepare-headers + " " , + dup string? [ string-lines ] when % + ] { } make ; -: quit ( -- ) - "QUIT\r\n" get-ok ; +: prepare-simple-message ( body subject to from -- body' to from ) + simple-headers >r >r prepare-message r> r> ; + +: send-message ( body headers to from -- ) + >r >r prepare-message r> r> send-raw-message ; + +: send-simple-message ( body subject to from -- ) + prepare-simple-message send-raw-message ; + +! Dirk's old AUTH CRAM-MD5 code. I don't know anything about +! CRAM MD5, and the old code didn't work properly either, so here +! it is in case anyone wants to fix it later. +! +! check-response used to have this clause: +! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } +! +! and the rest of the code was as follows: +! : (cram-md5-auth) ( -- response ) +! swap challenge get +! string>md5-hmac hex-string +! " " swap append append +! >base64 ; +! +! : cram-md5-auth ( key login -- ) +! "AUTH CRAM-MD5\r\n" get-ok +! (cram-md5-auth) "\r\n" append get-ok ; From 2f46a618a694e4eb8cc2830684b21ba64dba0a84 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:05:00 -0600 Subject: [PATCH 29/42] Add new word to calendar --- extra/calendar/calendar.factor | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index a1fe0a55ea..32c5c0233c 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -349,13 +349,23 @@ M: timestamp year. ( timestamp -- ) : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] string-out ; +: timestamp>rfc822-string ( timestamp -- str ) + #! RFC822 timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 +0200 + [ + dup (timestamp>string) + " " write + timestamp-gmt-offset { + { [ dup zero? ] [ drop "GMT" write ] } + { [ dup 0 < ] [ "-" write neg write-00 "00" write ] } + { [ dup 0 > ] [ "+" write write-00 "00" write ] } + } cond + ] string-out ; + : timestamp>http-string ( timestamp -- str ) #! http timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt [ - (timestamp>string) - " GMT" write - ] string-out ; + >gmt timestamp>rfc822-string ; : (timestamp>rfc3339) ( timestamp -- ) dup timestamp-year number>string write CHAR: - write1 From dad715e7b0e2fe985eb5b5027632c2ee0d4acaaf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:05:10 -0600 Subject: [PATCH 30/42] Update for io.logging change --- extra/http/server/responders/responders.factor | 4 ++-- extra/http/server/server.factor | 4 ++-- extra/webapps/planet/planet.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index 70503236f6..8f4f146508 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs hashtables html html.elements splitting http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib ; +strings io.server vectors assocs.lib io.logging ; IN: http.server.responders diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 99ed41afa3..f8ac503819 100644 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io strings splitting threads http http.server.responders sequences prettyprint -io.server ; +io.server io.logging ; IN: http.server diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index ede0c579de..b777780e11 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer prettyprint io.server ; +xml.writer prettyprint io.logging ; IN: webapps.planet : print-posting-summary ( posting -- ) @@ -90,7 +90,7 @@ SYMBOL: last-update [ fetch-feed ] [ - swap [ . error. ] with-log-stream f + swap [ . error. ] to-log-stream f ] recover ; : fetch-blogroll ( blogroll -- entries ) From 386d93b6e5a68b3d65a1b342a17cced48c554bdc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:05:28 -0600 Subject: [PATCH 31/42] Moved smtp-server.factor to smtp/server/server.factor --- extra/smtp/smtp-server.factor | 68 ----------------------------------- 1 file changed, 68 deletions(-) delete mode 100644 extra/smtp/smtp-server.factor diff --git a/extra/smtp/smtp-server.factor b/extra/smtp/smtp-server.factor deleted file mode 100644 index e980ee36e6..0000000000 --- a/extra/smtp/smtp-server.factor +++ /dev/null @@ -1,68 +0,0 @@ -! Copyright (C) 2007 Elie CHAFTARI -! See http://factorcode.org/license.txt for BSD license. - -! Usage: 8889 start-server -! $ telnet 127.0.0.1 8889 -! Trying 127.0.0.1... -! Connected to localhost. -! Escape character is '^]'. -! 220 hello -! EHLO -! 220 and..? -! MAIL FROM: -! 220 OK -! RCPT TO: -! 220 OK -! Hi -! 500 ERROR -! DATA -! 354 Enter message, ending with "." on a line by itself -! Hello I am still waiting for your call -! Thanks -! . -! 220 OK -! QUIT -! bye -! Connection closed by foreign host. - -USING: combinators kernel prettyprint io io.server sequences -namespaces ; - -SYMBOL: data-mode - -: process ( -- ) - readln { - { [ [ dup "HELO" head? ] keep "EHLO" head? or ] [ - "220 and..?\r\n" write flush t - ] } - { [ dup "QUIT" = ] [ - "bye\r\n" write flush f - ] } - { [ dup "MAIL FROM:" head? ] [ - "220 OK\r\n" write flush t - ] } - { [ dup "RCPT TO:" head? ] [ - "220 OK\r\n" write flush t - ] } - { [ dup "DATA" = ] [ - data-mode on - "354 Enter message, ending with \".\" on a line by itself\r\n" - write flush t - ] } - { [ dup "." = data-mode get and ] [ - data-mode off - "220 OK\r\n" write flush t - ] } - { [ data-mode get ] [ t ] } - { [ t ] [ - "500 ERROR\r\n" write flush t - ] } - } cond nip [ process ] when ; - -: start-server ( port -- ) - "Starting SMTP server on port " write dup . flush - internet-server "smtp-server" [ - 60000 stdio get set-timeout - "220 hello\r\n" write flush - process - ] with-server ; From b5e1edfeed462036ce9c211006cfca29273bf333 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:36:11 -0600 Subject: [PATCH 32/42] Removed obsolete vocab --- extra/tools/test/inference/authors.txt | 1 - extra/tools/test/inference/inference.factor | 15 --------------- 2 files changed, 16 deletions(-) delete mode 100755 extra/tools/test/inference/authors.txt delete mode 100755 extra/tools/test/inference/inference.factor diff --git a/extra/tools/test/inference/authors.txt b/extra/tools/test/inference/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/tools/test/inference/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/tools/test/inference/inference.factor b/extra/tools/test/inference/inference.factor deleted file mode 100755 index cc77f4910d..0000000000 --- a/extra/tools/test/inference/inference.factor +++ /dev/null @@ -1,15 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: effects sequences kernel arrays quotations inference -tools.test words ; -IN: tools.test.inference - -: short-effect - dup effect-in length swap effect-out length 2array ; - -: unit-test-effect ( effect quot -- ) - >r 1quotation r> [ infer short-effect ] curry unit-test ; - -: must-infer ( word/quot -- ) - dup word? [ 1quotation ] when - [ infer drop ] curry [ ] swap unit-test ; From 6204f5698130c8d35056593e60b7c8ac79dab282 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 7 Feb 2008 13:48:49 -0600 Subject: [PATCH 33/42] fix gmt-offset on windows --- extra/calendar/windows/windows.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index 320400822c..afc040ef75 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -9,5 +9,4 @@ T{ windows-calendar } calendar-backend set-global M: windows-calendar gmt-offset ( -- float ) "TIME_ZONE_INFORMATION" [ GetTimeZoneInformation win32-error=0/f ] keep - [ TIME_ZONE_INFORMATION-Bias ] keep - TIME_ZONE_INFORMATION-DaylightBias + 60 /f neg ; + TIME_ZONE_INFORMATION-Bias 60 / neg ; From e05bb24a697b5721be7ed6d5caa9e1136b05f1ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 7 Feb 2008 14:17:07 -0600 Subject: [PATCH 34/42] make rfc822-string print fractional times fix windows gmt-offset yet again -- bad return value --- extra/calendar/calendar.factor | 16 +++++++++++----- extra/calendar/windows/windows.factor | 5 ++++- 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 32c5c0233c..012080d3b7 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -349,17 +349,23 @@ M: timestamp year. ( timestamp -- ) : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] string-out ; +: (write-gmt-offset) ( ratio -- ) + 1 /mod swap write-00 60 * write-00 ; + +: write-gmt-offset ( gmt-offset -- ) + { + { [ dup zero? ] [ drop "GMT" write ] } + { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } + { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } + } cond ; + : timestamp>rfc822-string ( timestamp -- str ) #! RFC822 timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 +0200 [ dup (timestamp>string) " " write - timestamp-gmt-offset { - { [ dup zero? ] [ drop "GMT" write ] } - { [ dup 0 < ] [ "-" write neg write-00 "00" write ] } - { [ dup 0 > ] [ "+" write write-00 "00" write ] } - } cond + timestamp-gmt-offset write-gmt-offset ] string-out ; : timestamp>http-string ( timestamp -- str ) diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index afc040ef75..9e34fdac00 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -6,7 +6,10 @@ TUPLE: windows-calendar ; T{ windows-calendar } calendar-backend set-global +: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline + M: windows-calendar gmt-offset ( -- float ) "TIME_ZONE_INFORMATION" - [ GetTimeZoneInformation win32-error=0/f ] keep + dup GetTimeZoneInformation + TIME_ZONE_ID_INVALID = [ win32-error ] when TIME_ZONE_INFORMATION-Bias 60 / neg ; From 0570449ffdabeaad6dc49e4489e178200568d1cc Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Feb 2008 15:14:40 -0600 Subject: [PATCH 35/42] Tweak builder --- extra/builder/builder.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 5bfd5e01cf..5e992ccc81 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -69,8 +69,8 @@ VAR: stamp "git" "pull" "--no-summary" - ! "git://factorcode.org/git/factor.git" - "http://dharmatech.onigirihouse.com/factor.git" + "git://factorcode.org/git/factor.git" + ! "http://dharmatech.onigirihouse.com/factor.git" "master" } run-process process-status From 5310a2cabea0341d33f7096e4e7ff9f043717bc0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 17:07:43 -0600 Subject: [PATCH 36/42] New logging framework --- .../distributed/distributed.factor | 2 +- .../http/server/responders/responders.factor | 39 +++--- extra/http/server/server.factor | 6 +- extra/io/logging/logging-docs.factor | 26 ---- extra/io/logging/logging.factor | 47 ------- extra/io/logging/summary.txt | 1 - extra/io/server/server.factor | 40 +++--- extra/logging/analysis/analysis.factor | 69 ++++++++++ .../logging => logging/analysis}/authors.txt | 2 +- extra/logging/analysis/summary.txt | 1 + extra/logging/authors.txt | 1 + extra/logging/insomniac/authors.txt | 1 + extra/logging/insomniac/insomniac.factor | 49 +++++++ extra/logging/insomniac/summary.txt | 1 + extra/logging/logging.factor | 122 ++++++++++++++++++ extra/logging/parser/authors.txt | 1 + extra/logging/parser/parser.factor | 66 ++++++++++ extra/logging/parser/summary.txt | 1 + extra/logging/server/authors.txt | 1 + extra/logging/server/server.factor | 101 +++++++++++++++ extra/logging/server/summary.txt | 1 + extra/logging/summary.txt | 1 + extra/raptor/cron/cron.factor | 6 +- extra/smtp/smtp-tests.factor | 2 +- extra/smtp/smtp.factor | 47 ++++--- extra/tools/annotations/annotations.factor | 20 ++- extra/tools/browser/browser.factor | 1 + extra/webapps/file/file.factor | 18 ++- extra/webapps/planet/planet.factor | 20 +-- 29 files changed, 523 insertions(+), 170 deletions(-) mode change 100644 => 100755 extra/concurrency/distributed/distributed.factor mode change 100644 => 100755 extra/http/server/responders/responders.factor mode change 100644 => 100755 extra/http/server/server.factor delete mode 100644 extra/io/logging/logging-docs.factor delete mode 100644 extra/io/logging/logging.factor delete mode 100644 extra/io/logging/summary.txt create mode 100755 extra/logging/analysis/analysis.factor rename extra/{io/logging => logging/analysis}/authors.txt (92%) mode change 100644 => 100755 create mode 100755 extra/logging/analysis/summary.txt create mode 100755 extra/logging/authors.txt create mode 100755 extra/logging/insomniac/authors.txt create mode 100755 extra/logging/insomniac/insomniac.factor create mode 100755 extra/logging/insomniac/summary.txt create mode 100755 extra/logging/logging.factor create mode 100755 extra/logging/parser/authors.txt create mode 100755 extra/logging/parser/parser.factor create mode 100755 extra/logging/parser/summary.txt create mode 100755 extra/logging/server/authors.txt create mode 100755 extra/logging/server/server.factor create mode 100755 extra/logging/server/summary.txt create mode 100755 extra/logging/summary.txt mode change 100644 => 100755 extra/raptor/cron/cron.factor mode change 100644 => 100755 extra/smtp/smtp-tests.factor mode change 100644 => 100755 extra/smtp/smtp.factor diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor old mode 100644 new mode 100755 index 9024c0630f..83052b803a --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -14,7 +14,7 @@ C: node : node-server ( port -- ) internet-server - "concurrency" + "concurrency.distributed" [ handle-node-client ] with-server ; : send-to-node ( msg pid host port -- ) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor old mode 100644 new mode 100755 index 8f4f146508..e4e0e257c4 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs hashtables html html.elements splitting http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib io.logging ; +strings io.server vectors assocs.lib logging ; IN: http.server.responders @@ -22,7 +22,7 @@ SYMBOL: responders

write

; : error-head ( error -- ) - dup log-error response + response H{ { "Content-Type" V{ "text/html" } } } print-header nl ; : httpd-error ( error -- ) @@ -30,6 +30,8 @@ SYMBOL: responders dup error-head "head" "method" get = [ drop ] [ error-body ] if ; +\ httpd-error ERROR add-error-logging + : bad-request ( -- ) [ ! Make httpd-error print a body @@ -84,17 +86,21 @@ SYMBOL: max-post-request : read-post-request ( header -- str hash ) content-length [ read dup query>hash ] [ f f ] if* ; -: log-headers ( hash -- ) +LOG: log-headers DEBUG + +: interesting-headers ( assoc -- string ) [ - drop { - "user-agent" - "referer" - "x-forwarded-for" - "host" - } member? - ] assoc-subset [ - ": " swap 3append log-message - ] multi-assoc-each ; + [ + drop { + "user-agent" + "referer" + "x-forwarded-for" + "host" + } member? + ] assoc-subset [ + ": " swap 3append % "\n" % + ] multi-assoc-each + ] "" make ; : prepare-url ( url -- url ) #! This is executed in the with-request namespace. @@ -105,7 +111,7 @@ SYMBOL: max-post-request : prepare-header ( -- ) read-header dup "header" set - dup log-headers + dup interesting-headers log-headers read-post-request "response" set "raw-response" set ; ! Responders are called in a new namespace with these @@ -177,9 +183,6 @@ SYMBOL: max-post-request "/" "responder-url" set "default" responder call-responder ; -: log-responder ( path -- ) - "Calling responder " swap append log-message ; - : trim-/ ( url -- url ) #! Trim a leading /, if there is one. "/" ?head drop ; @@ -199,13 +202,15 @@ SYMBOL: max-post-request #! /foo/bar... - default responder used #! /responder/foo/bar - responder foo, argument bar vhost [ - dup log-responder trim-/ "responder/" ?head [ + trim-/ "responder/" ?head [ serve-explicit-responder ] [ serve-default-responder ] if ] bind ; +\ serve-responder DEBUG add-input-logging + : no-such-responder ( -- ) "404 No such responder" httpd-error ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor old mode 100644 new mode 100755 index f8ac503819..eca2253e2a --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io strings splitting threads http http.server.responders sequences prettyprint -io.server io.logging ; +io.server logging ; IN: http.server @@ -36,7 +36,6 @@ IN: http.server [ (handle-request) serve-responder ] with-scope ; : parse-request ( request -- ) - dup log-message " " split1 dup [ " HTTP" split1 drop url>path secure-path dup [ swap handle-request @@ -47,8 +46,9 @@ IN: http.server 2drop bad-request ] if ; +\ parse-request NOTICE add-input-logging + : httpd ( port -- ) - "Starting HTTP server on port " write dup . flush internet-server "http.server" [ 60000 stdio get set-timeout readln [ parse-request ] when* diff --git a/extra/io/logging/logging-docs.factor b/extra/io/logging/logging-docs.factor deleted file mode 100644 index 6cd03ce212..0000000000 --- a/extra/io/logging/logging-docs.factor +++ /dev/null @@ -1,26 +0,0 @@ -IN: io.logging -USING: help.markup help.syntax io ; - -HELP: log-stream -{ $var-description "Holds an output stream for logging messages." } -{ $see-also log-error log-client with-logging } ; - -HELP: log-message -{ $values { "str" "a string" } } -{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." } -{ $see-also log-error log-client } ; - -HELP: log-error -{ $values { "str" "a string" } } -{ $description "Logs an error message." } -{ $see-also log-message log-client } ; - -HELP: log-client -{ $values { "client" "a client socket stream" } } -{ $description "Logs an incoming client connection." } -{ $see-also log-message log-error } ; - -HELP: with-logging -{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } } -{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ; - diff --git a/extra/io/logging/logging.factor b/extra/io/logging/logging.factor deleted file mode 100644 index bd9dc0862e..0000000000 --- a/extra/io/logging/logging.factor +++ /dev/null @@ -1,47 +0,0 @@ -! Copyright (C) 2003, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel io calendar sequences io.files -io.sockets continuations prettyprint ; -IN: io.logging - -SYMBOL: log-stream - -: to-log-stream ( quot -- ) - log-stream get swap with-stream* ; inline - -: log-message ( str -- ) - [ - "[" write now timestamp>string write "] " write - print flush - ] to-log-stream ; - -: log-error ( str -- ) "Error: " swap append log-message ; - -: log-client ( client -- ) - "Accepted connection from " - swap client-stream-addr unparse append log-message ; - -: log-file ( service -- path ) - ".log" append resource-path ; - -: with-log-stream ( stream quot -- ) - log-stream get [ nip call ] [ - log-stream swap with-variable - ] if ; inline - -: with-log-file ( file quot -- ) - >r r> - [ with-log-stream ] curry - with-disposal ; inline - -: with-log-stdio ( quot -- ) - stdio get swap with-log-stream ; inline - -: with-logging ( service quot -- ) - over [ - >r log-file - "Writing log messages to " write dup print flush r> - with-log-file - ] [ - nip with-log-stdio - ] if ; inline diff --git a/extra/io/logging/summary.txt b/extra/io/logging/summary.txt deleted file mode 100644 index 0edce8f0cf..0000000000 --- a/extra/io/logging/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Basic logging framework for server applications diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 182712c984..829da27f6e 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,32 +1,34 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.sockets io.files io.logging continuations kernel +USING: io io.sockets io.files logging continuations kernel math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar qualified ; QUALIFIED: concurrency IN: io.server -: with-client ( quot client -- ) - dup log-client - [ swap with-stream ] 2curry concurrency:spawn drop ; inline +LOG: accepted-connection NOTICE + +: with-client ( client quot -- ) + [ + over client-stream-addr accepted-connection + with-stream* + ] curry with-disposal ; inline + +\ with-client NOTICE add-error-logging : accept-loop ( server quot -- ) - [ swap accept with-client ] 2keep accept-loop ; inline + [ + >r accept r> [ with-client ] 2curry concurrency:spawn + ] 2keep accept-loop ; inline : server-loop ( server quot -- ) [ accept-loop ] curry with-disposal ; inline : spawn-server ( addrspec quot -- ) - "Waiting for connections on " pick unparse append - log-message - [ - >r r> server-loop - ] [ - "Cannot spawn server: " print - print-error - 2drop - ] recover ; inline + >r r> server-loop ; inline + +\ spawn-server NOTICE add-error-logging : local-server ( port -- seq ) "localhost" swap t resolve-host ; @@ -39,19 +41,21 @@ IN: io.server [ spawn-server ] curry concurrency:parallel-each ] curry with-logging ; inline -: log-datagram ( addrspec -- ) - "Received datagram from " swap unparse append log-message ; +: received-datagram ( addrspec -- ) drop ; + +\ received-datagram NOTICE add-input-logging : datagram-loop ( quot datagram -- ) [ - [ receive dup log-datagram >r swap call r> ] keep + [ receive dup received-datagram >r swap call r> ] keep pick [ send ] [ 3drop ] keep ] 2keep datagram-loop ; inline : spawn-datagrams ( quot addrspec -- ) - "Waiting for datagrams on " over unparse append log-message [ datagram-loop ] with-disposal ; inline +\ spawn-datagrams NOTICE add-input-logging + : with-datagrams ( seq service quot -- ) [ [ swap spawn-datagrams ] curry concurrency:parallel-each diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor new file mode 100755 index 0000000000..df53a8e70b --- /dev/null +++ b/extra/logging/analysis/analysis.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces words assocs logging sorting +prettyprint io io.styles strings logging.parser ; +IN: logging.analysis + +SYMBOL: word-names +SYMBOL: errors +SYMBOL: word-histogram +SYMBOL: message-histogram + +: analyze-entry ( entry -- ) + dup second ERROR eq? [ dup errors get push ] when + 1 over third word-histogram get at+ + dup third word-names get member? [ + 1 over 1 tail message-histogram get at+ + ] when + drop ; + +: analyze-entries ( entries word-names -- errors word-histogram message-histogram ) + [ + word-names set + V{ } clone errors set + H{ } clone word-histogram set + H{ } clone message-histogram set + + [ + analyze-entry + ] each + + errors get + word-histogram get + message-histogram get + ] with-scope ; + +: histogram. ( assoc quot -- ) + standard-table-style [ + >r >alist sort-values r> [ + [ >r swap r> with-cell pprint-cell ] with-row + ] curry assoc-each + ] tabular-output ; + +: log-entry. + [ + dup first [ write ] with-cell + dup second [ pprint ] with-cell + dup third [ write ] with-cell + fourth "\n" join [ write ] with-cell + ] with-row ; + +: errors. ( errors -- ) + standard-table-style + [ [ log-entry. ] each ] tabular-output ; + +: analysis. ( errors word-histogram message-histogram -- ) + "==== INTERESTING MESSAGES:" print nl + "Total: " write dup values sum . nl + [ + dup second write ": " write third "\n" join write + ] histogram. + nl + "==== WORDS:" print nl + [ write ] histogram. + nl + "==== ERRORS:" print nl + errors. ; + +: log-analysis ( lines word-names -- ) + >r parse-log r> analyze-entries analysis. ; diff --git a/extra/io/logging/authors.txt b/extra/logging/analysis/authors.txt old mode 100644 new mode 100755 similarity index 92% rename from extra/io/logging/authors.txt rename to extra/logging/analysis/authors.txt index 1901f27a24..56f4654064 --- a/extra/io/logging/authors.txt +++ b/extra/logging/analysis/authors.txt @@ -1 +1 @@ -Slava Pestov +Slava Pestov diff --git a/extra/logging/analysis/summary.txt b/extra/logging/analysis/summary.txt new file mode 100755 index 0000000000..e614abca96 --- /dev/null +++ b/extra/logging/analysis/summary.txt @@ -0,0 +1 @@ +Analyze logs and produce summaries diff --git a/extra/logging/authors.txt b/extra/logging/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/insomniac/authors.txt b/extra/logging/insomniac/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/insomniac/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor new file mode 100755 index 0000000000..b065dec9d3 --- /dev/null +++ b/extra/logging/insomniac/insomniac.factor @@ -0,0 +1,49 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: logging.analysis logging.server logging smtp io.sockets +kernel io.files io.streams.string namespaces raptor.cron ; +IN: logging.insomniac + +SYMBOL: insomniac-config + +SYMBOL: insomniac-smtp-host +SYMBOL: insomniac-smtp-port +SYMBOL: insomniac-sender +SYMBOL: insomniac-recipients + +: ?log-analysis ( service word-names -- string/f ) + >r log-path 1 log# dup exists? [ + file-lines r> [ log-analysis ] string-out + ] [ + r> 2drop f + ] if ; + +: with-insomniac-smtp ( quot -- ) + [ + insomniac-smtp-host get [ smtp-host set ] when* + insomniac-smtp-port get [ smtp-port set ] when* + call + ] with-scope ; inline + +: email-subject ( service -- string ) + [ "[INSOMNIAC] " % % " on " % host-name % ] "" make ; + +: (email-log-report) ( service word-names -- ) + [ + over >r + ?log-analysis dup [ + r> email-subject + insomniac-recipients get + insomniac-sender get + send-simple-message + ] [ r> 2drop ] if + ] with-insomniac-smtp ; + +: email-log-report ( service word-names -- ) + (email-log-report) ; + +\ email-log-report NOTICE add-error-logging + +: schedule-insomniac ( service word-names -- ) + { 25 } { 6 } f f f -rot + [ email-log-report ] 2curry schedule ; diff --git a/extra/logging/insomniac/summary.txt b/extra/logging/insomniac/summary.txt new file mode 100755 index 0000000000..ddd21fb5b9 --- /dev/null +++ b/extra/logging/insomniac/summary.txt @@ -0,0 +1 @@ +Task which rotates logs and e-mails summaries diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor new file mode 100755 index 0000000000..71ea247567 --- /dev/null +++ b/extra/logging/logging.factor @@ -0,0 +1,122 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: logging.server sequences namespaces concurrency +words kernel arrays shuffle tools.annotations +prettyprint.config prettyprint debugger io.streams.string +splitting continuations effects arrays.lib parser strings +combinators.lib ; +IN: logging + +SYMBOL: DEBUG +SYMBOL: NOTICE +SYMBOL: WARNING +SYMBOL: ERROR +SYMBOL: CRITICAL + +: log-levels + { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; + +: send-to-log-server ( array string -- ) + add* "log-server" get send ; + +SYMBOL: log-service + +: check-log-message + pick string? + pick word? + pick word? and and + [ "Bad parameters to log-message" throw ] unless ; + +: log-message ( msg word level -- ) + check-log-message + log-service get dup [ + >r >r >r string-lines r> word-name r> word-name r> + 4array "log-message" send-to-log-server + ] [ + 4drop + ] if ; + +: rotate-logs ( -- ) + { } "rotate-logs" send-to-log-server ; + +: close-log-files ( -- ) + { } "close-log-files" send-to-log-server ; + +: with-logging ( service quot -- ) + log-service swap with-variable ; inline + +! Aspect-oriented programming idioms + +message ( obj -- inputs>message ) + dup one-string? [ first ] [ + H{ + { string-limit f } + { line-limit 1 } + { nesting-limit 3 } + { margin 0 } + } clone [ unparse ] bind + ] if ; + +PRIVATE> + +: (define-logging) ( word level quot -- ) + >r >r dup r> r> 2curry annotate ; + +: call-logging-quot ( quot word level -- quot' ) + "called" -rot [ log-message ] 3curry swap compose ; + +: add-logging ( word level -- ) + [ call-logging-quot ] (define-logging) ; + +: log-inputs ( n word level -- ) + log-service get [ + >r >r [ ndup ] keep narray inputs>message + r> r> log-message + ] [ + 3drop + ] if ; inline + +: input# stack-effect effect-in length ; + +: input-logging-quot ( quot word level -- quot' ) + over input# -rot [ log-inputs ] 3curry swap compose ; + +: add-input-logging ( word level -- ) + [ input-logging-quot ] (define-logging) ; + +: (log-error) ( object word level -- ) + log-service get [ + >r >r [ print-error ] string-out r> r> log-message + ] [ + 2drop rethrow + ] if ; + +: log-error ( object word -- ) ERROR (log-error) ; + +: log-critical ( object word -- ) CRITICAL (log-error) ; + +: error-logging-quot ( quot word -- quot' ) + dup stack-effect effect-in length + [ >r log-error r> ndrop ] 2curry + [ recover ] 2curry ; + +: add-error-logging ( word level -- ) + [ over >r input-logging-quot r> error-logging-quot ] + (define-logging) ; + +: LOG: + #! Syntax: name level + CREATE + dup reset-generic + dup scan-word + [ >r >r 1array inputs>message r> r> log-message ] 2curry + define ; parsing diff --git a/extra/logging/parser/authors.txt b/extra/logging/parser/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/parser/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor new file mode 100755 index 0000000000..f1cb7aa17e --- /dev/null +++ b/extra/logging/parser/parser.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser-combinators memoize kernel sequences +logging arrays words strings vectors io io.files +namespaces combinators combinators.lib logging.server ; +IN: logging.parser + +: string-of satisfy [ >string ] <@ ; + +: 'date' + [ CHAR: ] eq? not ] string-of + "[" "]" surrounded-by ; + +: 'log-level' + log-levels [ + [ word-name token ] keep [ nip ] curry <@ + ] map ; + +: 'word-name' + [ " :" member? not ] string-of ; + +SYMBOL: malformed + +: 'malformed-line' + [ drop t ] string-of [ malformed swap 2array ] <@ ; + +: 'log-message' + [ drop t ] string-of [ 1vector ] <@ ; + +MEMO: 'log-line' ( -- parser ) + 'date' " " token <& + 'log-level' " " token <& <&> + 'word-name' ": " token <& <:&> + 'log-message' <:&> + 'malformed-line' <|> ; + +: parse-log-line ( string -- entry ) + 'log-line' parse-1 ; + +: malformed? ( line -- ? ) + first malformed eq? ; + +: multiline? ( line -- ? ) + first first CHAR: - = ; + +: malformed-line + "Warning: malformed log line:" print + second print ; + +: add-multiline ( line -- ) + building get empty? [ + "Warning: log begins with multiline entry" print drop + ] [ + fourth first building get peek fourth push + ] if ; + +: parse-log ( lines -- entries ) + [ + [ + parse-log-line { + { [ dup malformed? ] [ malformed-line ] } + { [ dup multiline? ] [ add-multiline ] } + { [ t ] [ , ] } + } cond + ] each + ] { } make ; diff --git a/extra/logging/parser/summary.txt b/extra/logging/parser/summary.txt new file mode 100755 index 0000000000..cd5c68b156 --- /dev/null +++ b/extra/logging/parser/summary.txt @@ -0,0 +1 @@ +Log parser diff --git a/extra/logging/server/authors.txt b/extra/logging/server/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/server/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor new file mode 100755 index 0000000000..cddcea8d70 --- /dev/null +++ b/extra/logging/server/server.factor @@ -0,0 +1,101 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel io calendar sequences io.files +io.sockets continuations prettyprint assocs math.parser +words debugger math combinators concurrency arrays init +math.ranges strings ; +IN: logging.server + +: log-root ( -- string ) + \ log-root get "logs" resource-path or ; + +: log-path ( service -- path ) + log-root swap path+ ; + +: log# ( path n -- path' ) + number>string ".log" append path+ ; + +SYMBOL: log-files + +: open-log-stream ( service -- stream ) + log-path + dup make-directories + 1 log# ; + +: log-stream ( service -- stream ) + log-files get [ open-log-stream ] cache ; + +: (write-message) ( msg word-name level multi? -- ) + [ + "[" write 20 CHAR: - write "] " write + ] [ + "[" write now (timestamp>rfc3339) "] " write + ] if + write bl write ": " write print ; + +: write-message ( msg word-name level -- ) + rot [ empty? not ] subset { + { [ dup empty? ] [ 3drop ] } + { [ dup length 1 = ] [ first -rot f (write-message) ] } + { [ t ] [ + [ first -rot f (write-message) ] 3keep + 1 tail -rot [ t (write-message) ] 2curry each + ] } + } cond ; + +: (log-message) ( msg -- ) + #! msg: { msg word-name level service } + first4 log-stream [ write-message flush ] with-stream* ; + +: try-dispose ( stream -- ) + [ dispose ] curry [ error. ] recover ; + +: close-log-file ( service -- ) + log-files get delete-at* + [ try-dispose ] [ drop ] if ; + +: (close-log-files) ( -- ) + log-files get + dup values [ try-dispose ] each + clear-assoc ; + +: keep-logs 10 ; + +: ?delete-file ( path -- ) + dup exists? [ delete-file ] [ drop ] if ; + +: delete-oldest keep-logs log# ?delete-file ; + +: ?rename-file ( old new -- ) + over exists? [ rename-file ] [ 2drop ] if ; + +: advance-log ( path n -- ) + [ 1- log# ] 2keep log# ?rename-file ; + +: rotate-log ( service -- ) + dup close-log-file + log-path + dup delete-oldest + keep-logs 1 [a,b] [ advance-log ] with each ; + +: (rotate-logs) ( -- ) + (close-log-files) + log-root directory [ drop rotate-log ] assoc-each ; + +: log-server-loop + [ + receive unclip { + { "log-message" [ (log-message) ] } + { "rotate-logs" [ drop (rotate-logs) ] } + { "close-log-files" [ drop (close-log-files) ] } + } case + ] [ error. (close-log-files) ] recover + log-server-loop ; + +: log-server ( -- ) + [ log-server-loop ] spawn "log-server" set-global ; + +[ + H{ } clone log-files set-global + log-server +] "logging" add-init-hook diff --git a/extra/logging/server/summary.txt b/extra/logging/server/summary.txt new file mode 100755 index 0000000000..bebf3465f1 --- /dev/null +++ b/extra/logging/server/summary.txt @@ -0,0 +1 @@ +Distributed concurrency log server diff --git a/extra/logging/summary.txt b/extra/logging/summary.txt new file mode 100755 index 0000000000..dbf29c2112 --- /dev/null +++ b/extra/logging/summary.txt @@ -0,0 +1 @@ +AOP Logging framework with support for log rotation and machine-readable logs diff --git a/extra/raptor/cron/cron.factor b/extra/raptor/cron/cron.factor old mode 100644 new mode 100755 index 8158a03286..e20598d2eb --- a/extra/raptor/cron/cron.factor +++ b/extra/raptor/cron/cron.factor @@ -1,6 +1,6 @@ USING: kernel namespaces threads sequences calendar - combinators.cleave combinators.lib ; + combinators.cleave combinators.lib debugger ; IN: raptor.cron @@ -43,9 +43,9 @@ C: when ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : recurring-job ( when quot -- ) - [ swap when=now? [ call ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ; + [ swap when=now? [ try ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ; -: schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ; +: schedule ( when quot -- ) [ recurring-job ] 2curry in-thread ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor old mode 100644 new mode 100755 index 9a357fdc7d..eda8d7cc1f --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,4 +1,4 @@ -USING: smtp tools.test io.streams.string io.logging threads +USING: smtp tools.test io.streams.string threads smtp.server kernel sequences namespaces ; IN: temporary diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor old mode 100644 new mode 100755 index 77bfb6cd82..211fbbcabd --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces io kernel io.logging io.sockets sequences +USING: namespaces io kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings math.parser random system calendar ; @@ -12,21 +12,18 @@ SYMBOL: smtp-port 25 smtp-port set-global SYMBOL: read-timeout 60000 read-timeout set-global SYMBOL: esmtp t esmtp set-global -: log-smtp-connection ( host port -- ) - [ - "Establishing SMTP connection to " % swap % ":" % # - ] "" make log-message ; +: log-smtp-connection ( host port -- ) 2drop ; + +\ log-smtp-connection NOTICE add-input-logging : with-smtp-connection ( quot -- ) - [ - smtp-host get smtp-port get - 2dup log-smtp-connection - [ - smtp-domain [ host-name or ] change - read-timeout get stdio get set-timeout - call - ] with-stream - ] with-log-stdio ; inline + smtp-host get smtp-port get + 2dup log-smtp-connection + [ + smtp-domain [ host-name or ] change + read-timeout get stdio get set-timeout + call + ] with-stream ; inline : crlf "\r\n" write ; @@ -58,20 +55,20 @@ SYMBOL: esmtp t esmtp set-global : quit ( -- ) "QUIT" write crlf ; -: log-response ( string -- ) "SMTP: " swap append log-message ; +LOG: smtp-response DEBUG : check-response ( response -- ) { - { [ dup "220" head? ] [ log-response ] } - { [ dup "235" swap subseq? ] [ log-response ] } - { [ dup "250" head? ] [ log-response ] } - { [ dup "221" head? ] [ log-response ] } - { [ dup "bye" head? ] [ log-response ] } + { [ dup "220" head? ] [ smtp-response ] } + { [ dup "235" swap subseq? ] [ smtp-response ] } + { [ dup "250" head? ] [ smtp-response ] } + { [ dup "221" head? ] [ smtp-response ] } + { [ dup "bye" head? ] [ smtp-response ] } { [ dup "4" head? ] [ "server busy" throw ] } - { [ dup "354" head? ] [ log-response ] } - { [ dup "50" head? ] [ log-response "syntax error" throw ] } - { [ dup "53" head? ] [ log-response "invalid authentication data" throw ] } - { [ dup "55" head? ] [ log-response "fatal error" throw ] } + { [ dup "354" head? ] [ smtp-response ] } + { [ dup "50" head? ] [ smtp-response "syntax error" throw ] } + { [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] } + { [ dup "55" head? ] [ smtp-response "fatal error" throw ] } { [ t ] [ "unknown error" throw ] } } cond ; @@ -80,7 +77,7 @@ SYMBOL: esmtp t esmtp set-global : process-multiline ( multiline -- response ) >r readln r> 2dup " " append head? [ - drop dup log-response + drop dup smtp-response ] [ swap check-response process-multiline ] if ; diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index cd0d574083..6dee51cbc0 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -7,23 +7,31 @@ IN: tools.annotations : reset ( word -- ) dup "unannotated-def" word-prop [ [ - dup "unannotated-def" word-prop define + dup dup "unannotated-def" word-prop define ] with-compilation-unit + f "unannotated-def" set-word-prop ] [ drop ] if ; : annotate ( word quot -- ) + over "unannotated-def" word-prop [ + "Cannot annotate a word twice" throw + ] when [ over dup word-def "unannotated-def" set-word-prop >r dup word-def r> call define ] with-compilation-unit ; inline +: word-inputs ( word -- seq ) + stack-effect [ + >r datastack r> effect-in length tail* + ] [ + datastack + ] if* ; + : entering ( str -- ) "/-- Entering: " write dup . - stack-effect [ - >r datastack r> effect-in length tail* stack. - ] [ - .s - ] if* "\\--" print flush ; + word-inputs stack. + "\\--" print flush ; : leaving ( str -- ) "/-- Leaving: " write dup . diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 7aefbc8aaa..48de69b025 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -127,6 +127,7 @@ MEMO: all-vocabs-seq ( -- seq ) { [ "windows." ?head ] [ t ] } { [ "cocoa" ?head ] [ t ] } { [ ".test" ?tail ] [ t ] } + { [ "raptor" ?head ] [ t ] } { [ dup "tools.deploy.app" = ] [ t ] } { [ t ] [ f ] } } cond nip ; diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor index 110b90f84a..552f5e0977 100755 --- a/extra/webapps/file/file.factor +++ b/extra/webapps/file/file.factor @@ -3,7 +3,7 @@ USING: calendar html io io.files kernel math math.parser http.server.responders http.server.templating namespaces parser sequences strings assocs hashtables debugger http.mime sorting -html.elements ; +html.elements logging ; IN: webapps.file @@ -58,6 +58,8 @@ SYMBOL: page [ [ dup page set run-template-file ] with-scope ] try drop ; +\ run-page DEBUG add-input-logging + : include-page ( filename -- ) "doc-root" get swap path+ run-page ; @@ -69,6 +71,8 @@ SYMBOL: page dup mime-type dup "application/x-factor-server-page" = [ drop serve-fhtml ] [ serve-static ] if ; +\ serve-file NOTICE add-input-logging + : file. ( name dirp -- ) [ "/" append ] when dup write ; @@ -104,15 +108,15 @@ SYMBOL: page ] if ; : serve-object ( filename -- ) - dup directory? [ serve-directory ] [ serve-file ] if ; + serving-path dup exists? [ + dup directory? [ serve-directory ] [ serve-file ] if + ] [ + drop "404 not found" httpd-error + ] if ; : file-responder ( -- ) "doc-root" get [ - "argument" get serving-path dup exists? [ - serve-object - ] [ - drop "404 not found" httpd-error - ] if + "argument" get serve-object ] [ "404 doc-root not set" httpd-error ] if ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index b777780e11..a9fd443fe6 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer prettyprint io.logging ; +xml.writer prettyprint logging ; IN: webapps.planet : print-posting-summary ( posting -- ) @@ -75,27 +75,19 @@ SYMBOL: cached-postings SYMBOL: last-update -: fetch-feed ( triple -- feed ) - second - "Fetching " over append log-message - dup download-feed feed-entries - "Done fetching " swap append log-message ; - : ( author entry -- entry' ) clone [ ": " swap entry-title 3append ] keep [ set-entry-title ] keep ; -: ?fetch-feed ( triple -- feed/f ) - [ - fetch-feed - ] [ - swap [ . error. ] to-log-stream f - ] recover ; +: fetch-feed ( url -- feed ) + download-feed feed-entries ; + +\ fetch-feed DEBUG add-error-logging : fetch-blogroll ( blogroll -- entries ) dup 0 - swap [ ?fetch-feed ] parallel-map + swap [ fetch-feed ] parallel-map [ [ ] with map ] 2map concat ; : sort-entries ( entries -- entries' ) From 6187a1e5e14978eec4a87e8f2ab094b20a9a8e0b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 17:55:31 -0600 Subject: [PATCH 37/42] Improved http.client, bootstrap.image.{download,upload} --- core/bootstrap/image/image.factor | 34 ++++++++++++------- extra/benchmark/bootstrap2/bootstrap2.factor | 4 +-- extra/bootstrap/image/download/authors.txt | 1 + .../bootstrap/image/download/download.factor | 25 ++++++++++++++ extra/bootstrap/image/download/summary.txt | 1 + extra/bootstrap/image/upload/authors.txt | 1 + extra/bootstrap/image/upload/summary.txt | 1 + extra/bootstrap/image/upload/upload.factor | 25 ++++++++++++++ extra/crypto/sha1/sha1.factor | 11 +++--- extra/http/client/client.factor | 27 +++++++-------- extra/io/server/server.factor | 3 +- extra/rss/rss.factor | 2 +- extra/tools/deploy/backend/backend.factor | 7 ++-- extra/webapps/fjsc/fjsc.factor | 2 +- extra/yahoo/yahoo.factor | 4 +-- 15 files changed, 102 insertions(+), 46 deletions(-) create mode 100644 extra/bootstrap/image/download/authors.txt create mode 100644 extra/bootstrap/image/download/download.factor create mode 100644 extra/bootstrap/image/download/summary.txt create mode 100644 extra/bootstrap/image/upload/authors.txt create mode 100644 extra/bootstrap/image/upload/summary.txt create mode 100644 extra/bootstrap/image/upload/upload.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 3dadee5193..7452e31cf8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -10,6 +10,23 @@ definitions debugger float-arrays quotations.private combinators.private combinators ; IN: bootstrap.image +: my-arch ( -- arch ) + cpu dup "ppc" = [ os "-" rot 3append ] when ; + +: boot-image-name ( arch -- string ) + "boot." swap ".image" 3append ; + +: my-boot-image-name ( -- string ) + my-arch boot-image-name ; + +: images ( -- seq ) + { + "x86.32" + "x86.64" + "linux-ppc" "macosx-ppc" + ! "arm" + } ; + le write ] curry each ] if ; -: image-name - "boot." architecture get ".image" 3append resource-path ; - : write-image ( image filename -- ) "Writing image to " write dup write "..." print flush [ (write-image) ] with-stream ; @@ -415,16 +429,10 @@ PRIVATE> begin-image "resource:/core/bootstrap/stage1.factor" run-file end-image - image get image-name write-image + image get + architecture get boot-image-name resource-path + write-image ] with-variable ; -: my-arch ( -- arch ) - cpu dup "ppc" = [ os "-" rot 3append ] when ; - : make-images ( -- ) - { - "x86.32" - "x86.64" - "linux-ppc" "macosx-ppc" - ! "arm" - } [ make-image ] each ; + images [ make-image ] each ; diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor index bde92a2260..54bc73f4a1 100755 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/extra/benchmark/bootstrap2/bootstrap2.factor @@ -1,4 +1,4 @@ -USING: io.files io.launcher system tools.deploy.backend +USING: io.files io.launcher system bootstrap.image namespaces sequences kernel ; IN: benchmark.bootstrap2 @@ -6,7 +6,7 @@ IN: benchmark.bootstrap2 "." resource-path cd [ vm , - "-i=" boot-image-name append , + "-i=" my-boot-image-name append , "-output-image=foo.image" , "-no-user-init" , ] { } make run-process drop ; diff --git a/extra/bootstrap/image/download/authors.txt b/extra/bootstrap/image/download/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/bootstrap/image/download/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor new file mode 100644 index 0000000000..deed045221 --- /dev/null +++ b/extra/bootstrap/image/download/download.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: bootstrap.image.download +USING: http.client crypto.md5 splitting assocs kernel io.files +bootstrap.image sequences io ; + +: url "http://factorcode.org/images/latest/" ; + +: download-checksums ( -- alist ) + url "checksums.txt" append http-get + string-lines [ " " split1 ] { } map>assoc ; + +: need-new-image? ( image -- ? ) + dup exists? + [ dup file>md5str swap download-checksums at = not ] + [ drop t ] if ; + +: download-image ( arch -- ) + boot-image-name dup need-new-image? [ + "Downloading " write dup write "..." print + url swap append download + ] [ + "Boot image up to date" print + drop + ] if ; diff --git a/extra/bootstrap/image/download/summary.txt b/extra/bootstrap/image/download/summary.txt new file mode 100644 index 0000000000..fc0ed97ff1 --- /dev/null +++ b/extra/bootstrap/image/download/summary.txt @@ -0,0 +1 @@ +Smart image downloader utility which first checks MD5 checksum diff --git a/extra/bootstrap/image/upload/authors.txt b/extra/bootstrap/image/upload/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/bootstrap/image/upload/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/bootstrap/image/upload/summary.txt b/extra/bootstrap/image/upload/summary.txt new file mode 100644 index 0000000000..85497270a2 --- /dev/null +++ b/extra/bootstrap/image/upload/summary.txt @@ -0,0 +1 @@ +Image upload utility diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor new file mode 100644 index 0000000000..a9f5d1dcd4 --- /dev/null +++ b/extra/bootstrap/image/upload/upload.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: bootstrap.image.upload +USING: http.client crypto.md5 splitting assocs kernel io.files +bootstrap.image sequences io namespaces io.launcher math ; + +: destination "slava@factorcode.org:www/images/latest/" ; + +: boot-image-names images [ boot-image-name ] map ; + +: compute-checksums ( -- ) + "checksums.txt" [ + boot-image-names [ dup write bl file>md5str print ] each + ] with-file-out ; + +: upload-images ( -- ) + [ + "scp" , boot-image-names % "checksums.txt" , destination , + ] { } make run-process + wait-for-process zero? [ "Upload failed" throw ] unless ; + +: new-images ( -- ) + make-images compute-checksums upload-images ; + +MAIN: new-images diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 94a51288bb..f6dfbcd031 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -48,14 +48,13 @@ SYMBOL: K ! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59) ! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79) : sha1-f ( B C D t -- f_tbcd ) - #! Maybe use dispatch 20 /i { - { [ dup 0 = ] [ drop >r over bitnot r> bitand >r bitand r> bitor ] } - { [ dup 1 = ] [ drop bitxor bitxor ] } - { [ dup 2 = ] [ drop 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] } - { [ dup 3 = ] [ drop bitxor bitxor ] } - } cond ; + { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] } + { 1 [ bitxor bitxor ] } + { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] } + { 3 [ bitxor bitxor ] } + } case ; : make-w ( str -- ) #! compute w, steps a-b of RFC 3174, section 6.1 diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 8e6d8257a4..109bf17c40 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -47,32 +47,31 @@ DEFER: http-get-stream dispose "location" swap peek-at nip http-get-stream ] when ; +: default-timeout 60 1000 * over set-timeout ; + : http-get-stream ( url -- code headers stream ) #! Opens a stream for reading from an HTTP URL. parse-url over parse-host [ [ [ get-request read-response ] with-stream* ] keep + default-timeout ] [ ] [ dispose ] cleanup do-redirect ; -: http-get ( url -- code headers string ) - #! Opens a stream for reading from an HTTP URL. - [ - http-get-stream [ stdio get contents ] with-stream - ] with-scope ; +: success? ( code -- ? ) 200 = ; + +: check-response ( code headers stream -- stream ) + nip swap success? + [ dispose "HTTP download failed" throw ] unless ; + +: http-get ( url -- string ) + http-get-stream check-response contents ; : download-name ( url -- name ) file-name "?" split1 drop "/" ?tail drop ; -: default-timeout 60 1000 * over set-timeout ; - -: success? ( code -- ? ) 200 = ; - : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get-stream nip default-timeout swap success? [ - r> stream-copy - ] [ - r> drop dispose "HTTP download failed" throw - ] if ; + >r http-get-stream check-response + r> stream-copy ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 829da27f6e..a23984c207 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -19,7 +19,8 @@ LOG: accepted-connection NOTICE : accept-loop ( server quot -- ) [ - >r accept r> [ with-client ] 2curry concurrency:spawn + >r accept r> [ with-client ] 2curry + concurrency:spawn drop ] 2keep accept-loop ; inline : server-loop ( server quot -- ) diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index be2f648189..0591c60014 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -78,7 +78,7 @@ C: entry : download-feed ( url -- feed ) #! Retrieve an news syndication file, return as a feed tuple. - http-get-stream rot 200 = [ + http-get-stream rot success? [ nip read-feed ] [ 2drop "Error retrieving newsfeed file" throw diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 95d19712c0..c295f6369d 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -24,12 +24,9 @@ IN: tools.deploy.backend dup duplex-stream-out dispose copy-lines ; -: boot-image-name ( -- string ) - "boot." my-arch ".image" 3append ; - : make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. - boot-image-name resource-path exists? + my-boot-image-name resource-path exists? [ my-arch make-image ] unless ; : ?, [ , ] [ drop ] if ; @@ -49,7 +46,7 @@ IN: tools.deploy.backend : staging-command-line ( config -- flags ) [ - "-i=" boot-image-name append , + "-i=" my-boot-image-name append , "-output-image=" over staging-image-name append , diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index 19dab4ed1b..55609c72f9 100755 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -25,7 +25,7 @@ IN: webapps.fjsc : compile-url ( url -- ) #! Compile the factor code at the given url, return the javascript. dup "http:" head? [ "Unable to access remote sites." throw ] when - "http://" "Host" header-param rot 3append http-get 2nip compile "();" write flush ; + "http://" "Host" header-param rot 3append http-get compile "();" write flush ; \ compile-url { { "url" v-required } diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index 2c982306cd..1725c10a44 100644 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -26,6 +26,4 @@ C: result ] "" make ; : search-yahoo ( search num -- seq ) - query http-get 2nip - [ "Search failed" throw ] unless* - string>xml parse-yahoo ; + query http-get string>xml parse-yahoo ; From b08409884e72dc4879942a23c56c10167cf5695f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 18:03:01 -0600 Subject: [PATCH 38/42] Add try-everything for Ed --- core/vocabs/loader/loader-docs.factor | 5 ---- core/vocabs/loader/loader.factor | 34 +++++++++------------------ extra/tools/browser/browser.factor | 14 ++++++++--- extra/tools/test/test-docs.factor | 2 +- extra/tools/test/test.factor | 6 ++--- 5 files changed, 26 insertions(+), 35 deletions(-) diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index f8626f3370..379b300eaa 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -124,11 +124,6 @@ HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; -HELP: require-all-error -{ $values { "vocabs" "a sequence of vocabularies" } } -{ $description "Throws a " { $link require-all-error } "." } -{ $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ; - HELP: refresh-all { $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 352ef9fe02..4fcb74df66 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -160,37 +160,25 @@ SYMBOL: load-help? drop ; ! third "Traceback" swap write-object ; -TUPLE: require-all-error vocabs ; +: load-failures. ( failures -- ) + [ load-error. nl ] each ; -: require-all-error ( vocabs -- ) - [ vocab-name ] map - \ require-all-error construct-boa throw ; - -M: require-all-error summary - drop "The require-all operation failed" ; - -: require-all ( vocabs -- ) - dup length 1 = [ first require ] [ +: require-all ( vocabs -- failures ) + [ [ [ - [ - [ require ] - [ error-continuation get 3array , ] - recover - ] each - ] { } make - dup empty? [ drop ] [ - dup [ load-error. nl ] each - keys require-all-error - ] if - ] with-compiler-errors - ] if ; + [ require ] + [ error-continuation get 3array , ] + recover + ] each + ] { } make + ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) 2dup [ f swap set-vocab-docs-loaded? ] each [ f swap set-vocab-source-loaded? ] each - append prune require-all ; + append prune require-all drop ; : refresh ( prefix -- ) to-refresh do-refresh ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 48de69b025..87b4ba9939 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -132,11 +132,17 @@ MEMO: all-vocabs-seq ( -- seq ) { [ t ] [ f ] } } cond nip ; -: load-everything ( -- ) +: filter-dangerous ( seq -- seq' ) + [ vocab-name dangerous? not ] subset ; + +: try-everything ( -- failures ) all-vocabs-seq - [ vocab-name dangerous? not ] subset + filter-dangerous require-all ; +: load-everything ( -- ) + try-everything drop ; + : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . add ] unless vocabs @@ -155,7 +161,9 @@ MEMO: all-vocabs-seq ( -- seq ) : load-children ( prefix -- ) all-child-vocabs values concat - require-all ; + filter-dangerous + require-all + drop ; : vocab-status-string ( vocab -- string ) { diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index c027073398..b756f9279e 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -29,7 +29,7 @@ $nl { $subsection run-tests } { $subsection run-all-tests } "The following word prints failures:" -{ $subsection failures. } ; +{ $subsection test-failures. } ; ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 0b1a495e90..192a248161 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -80,7 +80,7 @@ M: expected-error summary dup first print-error "Traceback" swap third write-object ; -: failures. ( assoc -- ) +: test-failures. ( assoc -- ) dup [ nl dup empty? [ @@ -104,10 +104,10 @@ M: expected-error summary ] if ; : test ( prefix -- ) - run-tests failures. ; + run-tests test-failures. ; : run-all-tests ( prefix -- failures ) "" run-tests ; : test-all ( -- ) - run-all-tests failures. ; + run-all-tests test-failures. ; From 6bbbd3f9043a4162ce70e11acf3a3afc88bda7c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 18:06:53 -0600 Subject: [PATCH 39/42] Forgot to call load-failures. --- core/vocabs/loader/loader.factor | 2 +- extra/tools/browser/browser.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 4fcb74df66..a1276341b3 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -178,7 +178,7 @@ SYMBOL: load-help? 2dup [ f swap set-vocab-docs-loaded? ] each [ f swap set-vocab-source-loaded? ] each - append prune require-all drop ; + append prune require-all load-failures. ; : refresh ( prefix -- ) to-refresh do-refresh ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 87b4ba9939..ae1901ff66 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -163,7 +163,7 @@ MEMO: all-vocabs-seq ( -- seq ) all-child-vocabs values concat filter-dangerous require-all - drop ; + load-failures. ; : vocab-status-string ( vocab -- string ) { From 4dfc151c89c04828d0beabf3a701deeaad48146d Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 Feb 2008 19:48:00 -0500 Subject: [PATCH 40/42] Solution to Project Euler problem 79 --- extra/project-euler/079/079.factor | 65 ++++++++++++++++++++++++ extra/project-euler/079/keylog.txt | 50 ++++++++++++++++++ extra/project-euler/project-euler.factor | 4 +- 3 files changed, 117 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/079/079.factor create mode 100644 extra/project-euler/079/keylog.txt diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor new file mode 100644 index 0000000000..d28484c881 --- /dev/null +++ b/extra/project-euler/079/079.factor @@ -0,0 +1,65 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs hashtables io.files kernel math math.parser namespaces sequences ; +IN: project-euler.079 + +! http://projecteuler.net/index.php?section=problems&id=79 + +! DESCRIPTION +! ----------- + +! A common security method used for online banking is to ask the user for three +! random characters from a passcode. For example, if the passcode was 531278, +! they may asked for the 2nd, 3rd, and 5th characters; the expected reply would +! be: 317. + +! The text file, keylog.txt, contains fifty successful login attempts. + +! Given that the three characters are always asked for in order, analyse the +! file so as to determine the shortest possible secret passcode of unknown +! length. + + +! SOLUTION +! -------- + +edges ( seq -- seq ) + [ + [ string>digits [ 2 head , ] keep 2 tail* , ] each + ] { } make ; + +: find-source ( seq -- elt ) + dup values swap keys [ prune ] 2apply seq-diff + dup empty? [ "Topological sort failed" throw ] [ first ] if ; + +: remove-source ( seq elt -- seq ) + [ swap member? not ] curry subset ; + +: (topological-sort) ( seq -- ) + dup length 1 > [ + dup find-source dup , remove-source (topological-sort) + ] [ + dup empty? [ drop ] [ first [ , ] each ] if + ] if ; + +PRIVATE> + +: topological-sort ( seq -- seq ) + [ [ (topological-sort) ] { } make ] keep + concat prune dupd seq-diff append ; + +: euler079 ( -- answer ) + source-079 >edges topological-sort 10 swap digits>integer ; + +! [ euler079 ] 100 ave-time +! 2 ms run / 0 ms GC ave time - 100 trials + +! TODO: prune and seq-diff are relatively slow; topological sort could be +! cleaned up and generalized much better, but it works for this problem + +MAIN: euler079 diff --git a/extra/project-euler/079/keylog.txt b/extra/project-euler/079/keylog.txt new file mode 100644 index 0000000000..b6f9903128 --- /dev/null +++ b/extra/project-euler/079/keylog.txt @@ -0,0 +1,50 @@ +319 +680 +180 +690 +129 +620 +762 +689 +762 +318 +368 +710 +720 +710 +629 +168 +160 +689 +716 +731 +736 +729 +316 +729 +729 +710 +769 +290 +719 +680 +318 +389 +162 +289 +162 +718 +729 +319 +790 +680 +890 +362 +319 +760 +316 +729 +380 +319 +728 +716 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 36a9069d77..c3db60c481 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -14,8 +14,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.043 project-euler.044 project-euler.048 project-euler.052 project-euler.067 project-euler.075 - project-euler.097 project-euler.134 project-euler.169 project-euler.173 - project-euler.175 ; + project-euler.079 project-euler.097 project-euler.134 project-euler.169 + project-euler.173 project-euler.175 ; IN: project-euler Date: Thu, 7 Feb 2008 20:25:03 -0500 Subject: [PATCH 41/42] Fix PE solutions using old math.parser --- extra/project-euler/041/041.factor | 2 +- extra/project-euler/043/043.factor | 6 +++--- extra/project-euler/079/079.factor | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/project-euler/041/041.factor b/extra/project-euler/041/041.factor index 60017f39a1..14084cc01d 100644 --- a/extra/project-euler/041/041.factor +++ b/extra/project-euler/041/041.factor @@ -32,7 +32,7 @@ IN: project-euler.041 : euler041 ( -- answer ) { 7 6 5 4 3 2 1 } all-permutations - [ 10 swap digits>integer ] map [ prime? ] find nip ; + [ 10 digits>integer ] map [ prime? ] find nip ; ! [ euler041 ] 100 ave-time ! 107 ms run / 7 ms GC ave time - 100 trials diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index abe455e273..54d75c6980 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -36,7 +36,7 @@ IN: project-euler.043 integer swap mod zero? ; + [ 1- dup 3 + ] dip subseq 10 digits>integer swap mod zero? ; : interesting? ( seq -- ? ) { @@ -53,7 +53,7 @@ PRIVATE> : euler043 ( -- answer ) 1234567890 number>digits all-permutations - [ interesting? ] subset [ 10 swap digits>integer ] map sum ; + [ interesting? ] subset [ 10 digits>integer ] map sum ; ! [ euler043 ] time ! 125196 ms run / 19548 ms GC time @@ -89,7 +89,7 @@ PRIVATE> PRIVATE> : euler043a ( -- answer ) - interesting-pandigitals [ 10 swap digits>integer ] sigma ; + interesting-pandigitals [ 10 digits>integer ] sigma ; ! [ euler043a ] 100 ave-time ! 19 ms run / 1 ms GC ave time - 100 trials diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index d28484c881..f068db77ec 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -54,7 +54,7 @@ PRIVATE> concat prune dupd seq-diff append ; : euler079 ( -- answer ) - source-079 >edges topological-sort 10 swap digits>integer ; + source-079 >edges topological-sort 10 digits>integer ; ! [ euler079 ] 100 ave-time ! 2 ms run / 0 ms GC ave time - 100 trials From 48b96a9e5bf8734e7b2fb484f533e668fc6ae6ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 19:51:37 -0600 Subject: [PATCH 42/42] Documentation updates, tags updates --- extra/asn1/tags.txt | 1 + extra/db/authors.txt | 1 + extra/db/summary.txt | 1 + extra/db/tags.txt | 1 + extra/furnace/tags.txt | 1 + extra/logging/analysis/analysis-docs.factor | 31 +++++ extra/logging/analysis/analysis.factor | 3 +- extra/logging/analysis/tags.txt | 1 + extra/logging/insomniac/insomniac-docs.factor | 44 ++++++ extra/logging/insomniac/insomniac.factor | 23 ++-- extra/logging/insomniac/tags.txt | 1 + extra/logging/logging-docs.factor | 130 ++++++++++++++++++ extra/logging/logging.factor | 26 ++-- extra/logging/parser/parser-docs.factor | 21 +++ extra/logging/parser/tags.txt | 1 + extra/logging/server/server-docs.factor | 4 + extra/logging/server/server.factor | 12 +- extra/logging/server/tags.txt | 1 + extra/logging/summary.txt | 2 +- extra/logging/tags.txt | 1 + 20 files changed, 277 insertions(+), 29 deletions(-) create mode 100644 extra/asn1/tags.txt create mode 100644 extra/db/authors.txt create mode 100644 extra/db/summary.txt create mode 100644 extra/db/tags.txt create mode 100644 extra/furnace/tags.txt create mode 100644 extra/logging/analysis/analysis-docs.factor create mode 100644 extra/logging/analysis/tags.txt create mode 100644 extra/logging/insomniac/insomniac-docs.factor create mode 100644 extra/logging/insomniac/tags.txt create mode 100644 extra/logging/logging-docs.factor create mode 100644 extra/logging/parser/parser-docs.factor create mode 100644 extra/logging/parser/tags.txt create mode 100644 extra/logging/server/server-docs.factor create mode 100644 extra/logging/server/tags.txt create mode 100644 extra/logging/tags.txt diff --git a/extra/asn1/tags.txt b/extra/asn1/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/asn1/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/db/authors.txt b/extra/db/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/db/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/db/summary.txt b/extra/db/summary.txt new file mode 100644 index 0000000000..daebf38da6 --- /dev/null +++ b/extra/db/summary.txt @@ -0,0 +1 @@ +Relational database abstraction layer diff --git a/extra/db/tags.txt b/extra/db/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/db/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/furnace/tags.txt b/extra/furnace/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/furnace/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/analysis/analysis-docs.factor b/extra/logging/analysis/analysis-docs.factor new file mode 100644 index 0000000000..2919f2bcd4 --- /dev/null +++ b/extra/logging/analysis/analysis-docs.factor @@ -0,0 +1,31 @@ +USING: help.markup help.syntax assocs logging math ; +IN: logging.analysis + +HELP: analyze-entries +{ $values { "entries" "a sequence of log entries" } { "word-names" "a sequence of strings" } { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } } +{ $description "Analyzes log entries:" + { $list + { "Errors (entries with level " { $link ERROR } " or " { $link CRITICAL } ") are collected into the " { $snippet "errors" } " sequence." } + { "All logging words are tallied into " { $snippet "word-histogram" } " - for example, this can tell you about HTTP server hit counts." } + { "All words listed in " { $snippet "word-names" } " have their messages tallied into " { $snippet "message-histogram" } " - for example, this can tell you about popular URLs on an HTTP server." } + } +} ; + +HELP: analysis. +{ $values { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } } +{ $description "Prints a logging report output by " { $link analyze-entries } ". Formatted output words are used, so the report looks nice in the UI or if sent to an HTML stream." } ; + +HELP: analyze-log +{ $values { "service" "a log service name" } { "n" integer } { "word-names" "a sequence of strings" } } +{ $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; + +ARTICLE: "logging.analysis" "Log analysis" +"The " { $vocab-link "logging.analysis" } " vocabulary builds on the " { $vocab-link "logging.parser" } " vocabulary. It parses log files and produces formatted summary reports. It is used by the " { $vocab-link "logger.insomniac" } " vocabulary to e-mail daily reports." +$nl +"Print log file summary:" +{ $subsection analyze-log } +"Factors:" +{ $subsection analyze-entries } +{ $subsection analysis. } ; + +ABOUT: "logging.analysis" diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor index df53a8e70b..b530c09b22 100755 --- a/extra/logging/analysis/analysis.factor +++ b/extra/logging/analysis/analysis.factor @@ -11,6 +11,7 @@ SYMBOL: message-histogram : analyze-entry ( entry -- ) dup second ERROR eq? [ dup errors get push ] when + dup second CRITICAL eq? [ dup errors get push ] when 1 over third word-histogram get at+ dup third word-names get member? [ 1 over 1 tail message-histogram get at+ @@ -65,5 +66,5 @@ SYMBOL: message-histogram "==== ERRORS:" print nl errors. ; -: log-analysis ( lines word-names -- ) +: analyze-log ( lines word-names -- ) >r parse-log r> analyze-entries analysis. ; diff --git a/extra/logging/analysis/tags.txt b/extra/logging/analysis/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/analysis/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor new file mode 100644 index 0000000000..64ac3b4ff6 --- /dev/null +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -0,0 +1,44 @@ +USING: help.markup help.syntax assocs strings logging +logging.analysis smtp ; +IN: logging.insomniac + +HELP: insomniac-smtp-host +{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ; + +HELP: insomniac-smtp-port +{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ; + +HELP: insomniac-sender +{ $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; + +HELP: insomniac-recipients +{ $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; + +HELP: ?analyze-log +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string" string } } +{ $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." } +{ $see-also analyze-log } ; + +HELP: email-log-report +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } } +{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; + +HELP: schedule-insomniac +{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } +{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ; + +ARTICLE: "logging.insomniac" "Automating log analysis and rotation" +"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary." +$nl +"Required configuration parameters:" +{ $subsection insomniac-sender } +{ $subsection insomniac-recipients } +"Optional configuration parameters:" +{ $subsection insomniac-smtp-host } +{ $subsection insomniac-smtp-port } +"E-mailing a one-off report:" +{ $subsection email-log-report } +"E-mailing reports and rotating logs on a daily basis:" +{ $subsection schedule-insomniac } ; + +ABOUT: "logging.insomniac" diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index b065dec9d3..d79eca3495 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -1,19 +1,17 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: logging.analysis logging.server logging smtp io.sockets -kernel io.files io.streams.string namespaces raptor.cron ; +kernel io.files io.streams.string namespaces raptor.cron assocs ; IN: logging.insomniac -SYMBOL: insomniac-config - SYMBOL: insomniac-smtp-host SYMBOL: insomniac-smtp-port SYMBOL: insomniac-sender SYMBOL: insomniac-recipients -: ?log-analysis ( service word-names -- string/f ) +: ?analyze-log ( service word-names -- string/f ) >r log-path 1 log# dup exists? [ - file-lines r> [ log-analysis ] string-out + file-lines r> [ analyze-log ] string-out ] [ r> 2drop f ] if ; @@ -31,7 +29,7 @@ SYMBOL: insomniac-recipients : (email-log-report) ( service word-names -- ) [ over >r - ?log-analysis dup [ + ?analyze-log dup [ r> email-subject insomniac-recipients get insomniac-sender get @@ -39,11 +37,12 @@ SYMBOL: insomniac-recipients ] [ r> 2drop ] if ] with-insomniac-smtp ; +\ (email-log-report) NOTICE add-error-logging + : email-log-report ( service word-names -- ) - (email-log-report) ; + "logging.insomniac" [ (email-log-report) ] with-logging ; -\ email-log-report NOTICE add-error-logging - -: schedule-insomniac ( service word-names -- ) - { 25 } { 6 } f f f -rot - [ email-log-report ] 2curry schedule ; +: schedule-insomniac ( alist -- ) + { 25 } { 6 } f f f -rot [ + [ email-log-report ] assoc-each rotate-logs + ] 2curry schedule ; diff --git a/extra/logging/insomniac/tags.txt b/extra/logging/insomniac/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/insomniac/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor new file mode 100644 index 0000000000..3b112e0166 --- /dev/null +++ b/extra/logging/logging-docs.factor @@ -0,0 +1,130 @@ +IN: logging +USING: help.markup help.syntax assocs math calendar +logging.server strings words quotations ; + +HELP: DEBUG +{ $description "Log level for debug messages." } ; + +HELP: NOTICE +{ $description "Log level for ordinary messages." } ; + +HELP: ERROR +{ $description "Log level for error messages." } ; + +HELP: CRITICAL +{ $description "Log level for critical errors which require immediate attention." } ; + +ARTICLE: "logging.levels" "Log levels" +"Several log levels are supported, from lowest to highest:" +{ $subsection DEBUG } +{ $subsection NOTICE } +{ $subsection ERROR } +{ $subsection CRITICAL } ; + +ARTICLE: "logging.files" "Log files" +"Each application that wishes to use logging must choose a log service name; the following combinator should wrap the top level of the application:" +{ $subsection with-logging } +"Log messages are written to " { $snippet "log-root/service/1.log" } ", where" +{ $list + { { $snippet "log-root" } " is the Factor source directory by default, but can be overriden with the " { $link log-root } " variable" } + { { $snippet "service" } " is the service name" } +} +"You can get the log path for a service:" +{ $subsection log-path } +{ $subsection log# } +"New log entries are always sent to " { $snippet "1.log" } " but " { $link "logging.rotation" } " moves " { $snippet "1.log" } " to " { $snippet "2.log" } ", " { $snippet "2.log" } " to " { $snippet "3.log" } ", and so on." ; + +HELP: log-message +{ $values { "msg" string } { "word" word } { "level" "a log level" } } +{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; + +HELP: add-logging +{ $values { "word" word } } +{ $description "Causes the word to log a message every time it is called." } ; + +HELP: add-input-logging +{ $values { "word" word } } +{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ; + +HELP: add-output-logging +{ $values { "word" word } } +{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ; + +HELP: add-error-logging +{ $values { "word" word } } +{ $description "Causes the word to log its input values and any errors it throws." +$nl +"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller." +$nl +"If called from a logging context, its input values are logged, and if it throws an error, the error is logged and the word returns normally. Any inputs are popped from the stack and " { $link f } " is pushed in place of each output." } ; + +HELP: log-error +{ $values { "error" "an error" } { "word" word } } +{ $description "Logs an error." } ; + +HELP: log-critical +{ $values { "critical" "an critical" } { "word" word } } +{ $description "Logs a critical error." } ; + +HELP: LOG: +{ $syntax "LOG: name level" } +{ $values { "name" "a new word name" } { "level" "a log level" } } +{ $description "Creates a word with stack effect " { $snippet "( object -- )" } " which logs its input and does nothing else." } ; + +ARTICLE: "logging.messages" "Logging messages" +"Logging messages explicitly:" +{ $subsection log-message } +{ $subsection log-error } +{ $subsection log-critical } +"A utility for defining words which just log and do nothing else:" +{ $subsection POSTPONE: LOG: } +"Annotating words to log; this uses the " { $link "tools.annotations" } " feature:" +{ $subsection add-input-logging } +{ $subsection add-output-logging } +{ $subsection add-error-logging } ; + +HELP: rotate-logs +{ $description "Rotates all logs. The highest numbered log file in each log directory is deleted, and each file is renamed so that its number increments by one. Subsequent logging calls will create a new #1 log file. This keeps log files from getting too large and makes them easier to search." } ; + +HELP: close-logs +{ $description "Closes all open log streams. Subsequent logging will re-open the streams. This should be used before moving or deleting log files." } ; + +HELP: with-logging +{ $values { "service" "a log service name" } { "quot" quotation } } +{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ; + +ARTICLE: "logging.rotation" "Log rotation" +"Log files should be rotated periodically to prevent unbounded growth." +{ $subsection rotate-logs } +{ $subsection close-logs } +"The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ; + +ARTICLE: "logging.server" "Log implementation" +"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead ot uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion." +$nl +"The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (log-message) } +"The " { $link rotate-logs } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (rotate-logs) } +"The " { $link close-logs } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (close-logs) } ; + +ARTICLE: "logging" "Logging framework" +"The " { $vocab-link "logging" } " vocabulary implements a comprehensive logging framework suitable for server-side production applications." +{ $subsection "logging.files" } +{ $subsection "logging.levels" } +{ $subsection "logging.messages" } +{ $subsection "logging.rotation" } +{ $subsection "logging.parser" } +{ $subsection "logging.analysis" } +{ $subsection "logging.insomniac" } +{ $subsection "logging.server" } ; + +ABOUT: "logging" + +! A workaround for circular dependency prohibition +USING: threads vocabs.loader ; +[ + yield + "logging.insomniac" require +] in-thread diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 71ea247567..d4f0bd1fbf 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -39,8 +39,8 @@ SYMBOL: log-service : rotate-logs ( -- ) { } "rotate-logs" send-to-log-server ; -: close-log-files ( -- ) - { } "close-log-files" send-to-log-server ; +: close-logs ( -- ) + { } "close-logs" send-to-log-server ; : with-logging ( service quot -- ) log-service swap with-variable ; inline @@ -56,7 +56,7 @@ SYMBOL: log-service [ dup first string? ] } && nip ; -: inputs>message ( obj -- inputs>message ) +: stack>message ( obj -- inputs>message ) dup one-string? [ first ] [ H{ { string-limit f } @@ -77,9 +77,9 @@ PRIVATE> : add-logging ( word level -- ) [ call-logging-quot ] (define-logging) ; -: log-inputs ( n word level -- ) +: log-stack ( n word level -- ) log-service get [ - >r >r [ ndup ] keep narray inputs>message + >r >r [ ndup ] keep narray stack>message r> r> log-message ] [ 3drop @@ -88,11 +88,19 @@ PRIVATE> : input# stack-effect effect-in length ; : input-logging-quot ( quot word level -- quot' ) - over input# -rot [ log-inputs ] 3curry swap compose ; + over input# -rot [ log-stack ] 3curry swap compose ; : add-input-logging ( word level -- ) [ input-logging-quot ] (define-logging) ; +: output# stack-effect effect-out length ; + +: output-logging-quot ( quot word level -- quot' ) + over output# -rot [ log-stack ] 3curry compose ; + +: add-output-logging ( word level -- ) + [ output-logging-quot ] (define-logging) ; + : (log-error) ( object word level -- ) log-service get [ >r >r [ print-error ] string-out r> r> log-message @@ -100,9 +108,9 @@ PRIVATE> 2drop rethrow ] if ; -: log-error ( object word -- ) ERROR (log-error) ; +: log-error ( error word -- ) ERROR (log-error) ; -: log-critical ( object word -- ) CRITICAL (log-error) ; +: log-critical ( error word -- ) CRITICAL (log-error) ; : error-logging-quot ( quot word -- quot' ) dup stack-effect effect-in length @@ -118,5 +126,5 @@ PRIVATE> CREATE dup reset-generic dup scan-word - [ >r >r 1array inputs>message r> r> log-message ] 2curry + [ >r >r 1array stack>message r> r> log-message ] 2curry define ; parsing diff --git a/extra/logging/parser/parser-docs.factor b/extra/logging/parser/parser-docs.factor new file mode 100644 index 0000000000..ee995749be --- /dev/null +++ b/extra/logging/parser/parser-docs.factor @@ -0,0 +1,21 @@ +IN: logging.parser +USING: help.markup help.syntax assocs logging math calendar ; + +HELP: parse-log +{ $values { "lines" "a sequence of strings" } { "entries" "a sequence of log entries" } } +{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where" + { $list + { { $snippet "timestamp" } " is a " { $link timestamp } } + { { $snippet "level" } " is a log level; see " { $link "logger.levels" } } + { { $snippet "word-name" } " is a string" } + { { $snippet "message" } " is a string" } + } +} ; + +ARTICLE: "logging.parser" "Log file parser" +"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $link "logging.insomniac" } " to analyze logs." +$nl +"There is only one primary entry point:" +{ $subsection parse-log } ; + +ABOUT: "logging.parser" diff --git a/extra/logging/parser/tags.txt b/extra/logging/parser/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/parser/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/server/server-docs.factor b/extra/logging/server/server-docs.factor new file mode 100644 index 0000000000..08b99dd1cc --- /dev/null +++ b/extra/logging/server/server-docs.factor @@ -0,0 +1,4 @@ +IN: logging.server +USING: help.syntax ; + +ABOUT: "logging.server" diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index cddcea8d70..0300208e7e 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -50,11 +50,11 @@ SYMBOL: log-files : try-dispose ( stream -- ) [ dispose ] curry [ error. ] recover ; -: close-log-file ( service -- ) +: close-log ( service -- ) log-files get delete-at* [ try-dispose ] [ drop ] if ; -: (close-log-files) ( -- ) +: (close-logs) ( -- ) log-files get dup values [ try-dispose ] each clear-assoc ; @@ -73,13 +73,13 @@ SYMBOL: log-files [ 1- log# ] 2keep log# ?rename-file ; : rotate-log ( service -- ) - dup close-log-file + dup close-log log-path dup delete-oldest keep-logs 1 [a,b] [ advance-log ] with each ; : (rotate-logs) ( -- ) - (close-log-files) + (close-logs) log-root directory [ drop rotate-log ] assoc-each ; : log-server-loop @@ -87,9 +87,9 @@ SYMBOL: log-files receive unclip { { "log-message" [ (log-message) ] } { "rotate-logs" [ drop (rotate-logs) ] } - { "close-log-files" [ drop (close-log-files) ] } + { "close-logs" [ drop (close-logs) ] } } case - ] [ error. (close-log-files) ] recover + ] [ error. (close-logs) ] recover log-server-loop ; : log-server ( -- ) diff --git a/extra/logging/server/tags.txt b/extra/logging/server/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/server/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/summary.txt b/extra/logging/summary.txt index dbf29c2112..42246bbd3e 100755 --- a/extra/logging/summary.txt +++ b/extra/logging/summary.txt @@ -1 +1 @@ -AOP Logging framework with support for log rotation and machine-readable logs +Logging framework with support for log rotation and machine-readable logs diff --git a/extra/logging/tags.txt b/extra/logging/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/tags.txt @@ -0,0 +1 @@ +enterprise